packages feed

xml-push 0.0.0.5 → 0.0.0.6

raw patch · 8 files changed

+61/−18 lines, 8 files

Files

examples/httpPullTlsSv.hs view
@@ -23,7 +23,8 @@ 		void . forkIO $ testPusher (undefined :: HttpPullTlsSv Handle) 			(One h) (HttpPullTlsSvArgs 				(HttpPullSvArgs isPll endPoll needResponse)-				(TlsArgs gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]+				(TlsArgs gtNm (const Nothing)+					["TLS_RSA_WITH_AES_128_CBC_SHA"] 					(Just ca) [(k, c)]))  isPll :: XmlNode -> Bool
examples/httpPushTlsE.hs view
@@ -22,7 +22,8 @@ 		(HttpPushArgs "localhost" 80 "" gtPth wntRspns) 		(tlsArgsCl "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca 			[(k', c')])-		(tlsArgsSv gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]+		(tlsArgsSv gtNm (const Nothing)+			["TLS_RSA_WITH_AES_128_CBC_SHA"] 			(Just ca) [(k', c')]) )  wntRspns :: XmlNode -> Bool
examples/httpPushTlsT.hs view
@@ -26,7 +26,8 @@ 				(tlsArgsCl "Yoshikuni" 					["TLS_RSA_WITH_AES_128_CBC_SHA"] 						ca [(k', c')])-				(tlsArgsSv gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]+				(tlsArgsSv gtNm (const Nothing)+					["TLS_RSA_WITH_AES_128_CBC_SHA"] 					(Just ca) [(k', c')]) )  wntRspns :: XmlNode -> Bool
src/Network/XmlPush/HttpPull/Tls/Server.hs view
@@ -12,13 +12,21 @@ import "monads-tf" Control.Monad.Trans import Control.Monad.Base import Control.Monad.Trans.Control+-- import Data.List+-- import Data.Char import Data.HandleLike import Data.Pipe import Data.Pipe.TChan+import Data.X509 hiding (getCertificate)+-- import Data.X509.Validation import Text.XML.Pipe+-- import Numeric import Network.PeyoTLS.Server import "crypto-random" Crypto.Random +-- import qualified Data.ByteString as BS+-- import qualified Data.ByteString.Char8 as BSC+ import Network.XmlPush import Network.XmlPush.HttpPull.Server.Common import Network.XmlPush.Tls.Server@@ -39,17 +47,35 @@ makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => 	One h -> HttpPullTlsSvArgs h -> HandleMonad h (HttpPullTlsSv h) makeHttpPull (One h) (HttpPullTlsSvArgs-	(HttpPullSvArgs ip ep ynr) (TlsArgs gn cs mca kcs)) = do+	(HttpPullSvArgs ip ep ynr) (TlsArgs gn cc cs mca kcs)) = do 	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG) 	(inc, otc) <- (`run` g) $ do 		t <- open h cs kcs mca-		runXml t ip ep ynr $ checkNameP t gn+		{-+		getCertificate t >>= hlDebug t "medium" . BSC.pack . show+			. toHexStr+			. flip getFingerprint HashSHA256+			-}+		runXml t ip ep ynr $ checkNameP t gn cc 	return $ HttpPullTlsSv (fromTChan inc) (toTChan otc) +{-+toHexStr :: Fingerprint -> String+toHexStr (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+-}+ checkNameP :: HandleLike h => TlsHandle h g -> (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> 	Pipe XmlNode XmlNode (TlsM h g) ()-checkNameP t gn = (await >>=) . maybe (return ()) $ \n -> do+checkNameP t gn cc = (await >>=) . maybe (return ()) $ \n -> do 	ok <- maybe (return True) (lift . checkName t) $ gn n-	unless ok $ error "checkName: bad client name"+	unless ok $ error "checkNameP: bad client name"+	let ck = maybe (const True) id $ cc n+	c <- lift $ getCertificate t+	unless (ck c) $ error "checkNameP: bad certificate" 	yield n-	checkNameP t gn+	checkNameP t gn cc
src/Network/XmlPush/HttpPush/Tls.hs view
@@ -20,11 +20,12 @@ import Data.Pipe import Data.Pipe.Flow import Data.Pipe.TChan-import Data.X509+import Data.X509 hiding (getCertificate) import Data.X509.CertificateStore import Text.XML.Pipe import Network.TigHTTP.Server import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Server (getCertificate) import Network.PeyoTLS.Client (ValidateHandle) import "crypto-random" Crypto.Random @@ -45,7 +46,8 @@  type TlsArgsSv = TS.TlsArgs -tlsArgsSv :: (XmlNode -> Maybe String) -> [Cl.CipherSuite] ->+tlsArgsSv :: (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Cl.CipherSuite] -> 	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] -> TlsArgsSv tlsArgsSv = TS.TlsArgs @@ -74,11 +76,11 @@ makeHttpPushTls :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => 	h -> h -> HttpPushTlsArgs h -> HandleMonad h (HttpPushTls h) makeHttpPushTls ch sh (HttpPushTlsArgs (HttpPushArgs hn pn pt gp wr)-	(TC.TlsArgs dn cs ca kcs) (TS.TlsArgs gn cs' mca' kcs')) = do+	(TC.TlsArgs dn cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do 	when (dn /= hn) $ error "makeHttpPushTls: conflicted domain name" 	v <- liftBase . atomically $ newTVar False 	(ci, co) <- clientC ch hn pn pt gp cs ca kcs-	(si, so) <- talk wr sh gn cs' mca' kcs'+	(si, so) <- talk wr sh gn cc cs' mca' kcs' 	return $ HttpPushTls v ci co si so  clientC :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>@@ -101,11 +103,11 @@ 	return (inc, otc)  talk :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	(XmlNode -> Bool) -> h ->-	(XmlNode -> Maybe String) -> [Sv.CipherSuite] ->+	(XmlNode -> Bool) -> h -> (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Sv.CipherSuite] -> 	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] -> 	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-talk wr h gn cs mca kcs = do+talk wr h gn cc cs mca kcs = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan 	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)@@ -117,6 +119,7 @@ 				=$= xmlEvent 				=$= convert fromJust 				=$= xmlNode []+				=$= checkCert t cc 				=$= checkName t gn 				=$= checkReply wr otc 				=$= toTChan inc@@ -125,6 +128,16 @@ 					Just n -> LBS.fromChunks [xmlString [n]] 					_ -> "") 	return (inc, otc)++checkCert :: HandleLike h => Sv.TlsHandle h g ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	Pipe XmlNode XmlNode (Sv.TlsM h g) ()+checkCert t cc = (await >>=) . maybe (return ()) $ \n -> do+	let ck = maybe (const True) id $ cc n+	c <- lift $ getCertificate t+	unless (ck c) $ error "checkCert: bad certificate"+	yield n+	checkCert t cc  checkName :: HandleLike h => Sv.TlsHandle h g -> (XmlNode -> Maybe String) -> 	Pipe XmlNode XmlNode (Sv.TlsM h g) ()
src/Network/XmlPush/Simple.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, PackageImports #-} -module Network.XmlPush.Simple (SimplePusher) where+module Network.XmlPush.Simple (SimplePusher, SimplePusherArgs(..)) where  import "monads-tf" Control.Monad.Trans import Control.Monad
src/Network/XmlPush/Tls/Server.hs view
@@ -9,6 +9,7 @@  data TlsArgs = TlsArgs { 	getClientName :: XmlNode -> Maybe String,+	checkCertificate :: XmlNode -> Maybe (SignedCertificate -> Bool), 	cipherSuites :: [CipherSuite], 	certificateAuthorities :: Maybe CertificateStore, 	keyChains :: [(CertSecretKey, CertificateChain)]
xml-push.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.5+version:	0.0.0.6 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.5+    tag:	xml-push-0.0.0.6  library     hs-source-dirs:	src