packages feed

xml-push 0.0.0.6 → 0.0.0.7

raw patch · 9 files changed

+201/−80 lines, 9 files

Files

examples/httpPushE.hs view
@@ -10,10 +10,15 @@ main :: IO () main = do 	ch <- connectTo "localhost" $ PortNumber 80+	testPusher (undefined :: HttpPush Handle) (Two (Just ch) Nothing)+		(HttpPushArgs (const Nothing) getServerHandle+			(Just ("localhost", 80, "/")) gtPth wntRspns)++getServerHandle :: Maybe (IO Handle)+getServerHandle = Just $ do 	soc <- listenOn $ PortNumber 8080-	(sh, _, _) <- accept soc-	testPusher (undefined :: HttpPush Handle) (Two ch sh)-		(HttpPushArgs "localhost" 80 "/" gtPth wntRspns)+	(h, _, _) <- accept soc+	return h  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
examples/httpPushT.hs view
@@ -5,6 +5,8 @@ import Text.XML.Pipe import Network +import qualified Data.ByteString.Char8 as BSC+ import Network.XmlPush.HttpPush import TestPusher @@ -13,9 +15,17 @@ 	soc <- listenOn $ PortNumber 80 	forever  $ do 		(sh, _, _) <- accept soc-		ch <- connectTo "localhost" $ PortNumber 8080-		testPusher (undefined :: HttpPush Handle) (Two ch sh)-			(HttpPushArgs "localhost" 8080 "/" gtPth wntRspns)+		testPusher (undefined :: HttpPush Handle) (Two Nothing $ Just sh)+			(HttpPushArgs getClientHandle Nothing+				Nothing gtPth wntRspns)++getClientHandle :: XmlNode -> Maybe (IO Handle, String, Int, FilePath)+getClientHandle (XmlNode (_, "client") [] [] [XmlCharData hn]) = Just (+	connectTo (BSC.unpack hn) $ PortNumber 8080,+	"localhost",+	8080,+	"/" )+getClientHandle _ = Nothing  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
examples/httpPushTlsE.hs view
@@ -16,15 +16,20 @@ 	k' <- readKey "certs/yoshikuni.sample_key" 	c' <- readCertificateChain ["certs/yoshikuni.sample_crt"] 	ch <- connectTo "localhost" $ PortNumber 80-	soc <- listenOn $ PortNumber 8080-	(sh, _, _) <- accept soc-	testPusher (undefined :: HttpPushTls Handle) (Two ch sh) (HttpPushTlsArgs-		(HttpPushArgs "localhost" 80 "" gtPth wntRspns)+	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 			[(k', c')]) 		(tlsArgsSv gtNm (const Nothing) 			["TLS_RSA_WITH_AES_128_CBC_SHA"] 			(Just ca) [(k', c')]) )++getServerHandle :: Maybe (IO Handle)+getServerHandle = Just $ do+	soc <- listenOn $ PortNumber 8080+	(h, _, _) <- accept soc+	return h  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
examples/httpPushTlsT.hs view
@@ -19,16 +19,24 @@ 	c' <- readCertificateChain ["certs/localhost.sample_crt"] 	forever  $ do 		(sh, _, _) <- accept soc-		ch <- connectTo "localhost" $ PortNumber 8080-		testPusher (undefined :: HttpPushTls Handle) (Two ch sh)+		testPusher (undefined :: HttpPushTls Handle) (Two Nothing $ Just sh) 			(HttpPushTlsArgs-				(HttpPushArgs "Yoshikuni" 8080 "" gtPth wntRspns)+				(HttpPushArgs getClientHandle Nothing+					Nothing gtPth wntRspns) 				(tlsArgsCl "Yoshikuni" 					["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')]) )++getClientHandle :: XmlNode -> Maybe (IO Handle, String, Int, FilePath)+getClientHandle (XmlNode (_, "client") [] [] [XmlCharData hn]) = Just (+	connectTo (BSC.unpack hn) $ PortNumber 8080,+	"Yoshikuni",+	8080,+	"" )+getClientHandle _ = Nothing  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
src/Network/XmlPush.hs view
@@ -25,4 +25,4 @@  data Zero a = Zero deriving Show data One a = One a deriving Show-data Two a = Two a a deriving Show+data Two a = Two (Maybe a) (Maybe a)
src/Network/XmlPush/HttpPush.hs view
@@ -35,7 +35,8 @@ 	type NumOfHandle HttpPush = Two 	type PusherArgs HttpPush = HttpPushArgs 	generate (Two ch sh) = makeHttpPush ch sh-	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=+--	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=+	readFrom hp = fromTChans [serverReadChan hp, clientReadChan hp] =$= 		setNeedReply (needReply hp) 	writeTo hp = (convert ((() ,) . Just) =$=) . toTChansM $ do 		nr <- liftBase . atomically . readTVar $ needReply hp@@ -45,43 +46,87 @@ 			(const True, clientWriteChan hp) ]  makeHttpPush :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	h -> h -> HttpPushArgs h -> HandleMonad h (HttpPush h)-makeHttpPush ch sh (HttpPushArgs hn pn pt gp wr) = do+	(Maybe h) -> (Maybe h) ->+	HttpPushArgs h -> HandleMonad h (HttpPush h)+makeHttpPush mch msh (HttpPushArgs gc gs hi gp wr) = do+	vch <- liftBase . atomically $ newTVar mch+	vsh <- liftBase . atomically $ newTVar msh 	v <- liftBase . atomically $ newTVar False-	(ci, co) <- clientC ch hn pn pt gp-	(si, so) <- talk wr sh+	vhi <- liftBase . atomically $ newTVar hi+	(ci, co) <- clientC vch vhi gp+	(si, so) <- talk wr vsh vch vhi gc gs 	return $ HttpPush v ci co si so  clientC :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> FilePath) -> 	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-clientC h hn pn pt gp = do+clientC vh vhi gp = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan-	void . liftBaseDiscard forkIO . runPipe_ $ fromTChan otc-		=$= filter isJust-		=$= convert fromJust-		=$= clientLoop h hn pn pt gp-		=$= convert (, False)-		=$= toTChan inc+	void . liftBaseDiscard forkIO $ do+		h <- liftBase . atomically $ do+			mh <- readTVar vh+			case mh of+				Just h -> return h+				_ -> retry+		(hn, pn, pt) <- liftBase . atomically $ do+			mhi <- readTVar vhi+			case mhi of+				Just hi -> return hi+				_ -> retry+		runPipe_ $ fromTChan otc+			=$= filter isJust+			=$= convert fromJust+			=$= clientLoop h hn pn pt gp+			=$= convert (, False)+			=$= toTChan inc 	return (inc, otc)  talk :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	(XmlNode -> Bool) ->-	h -> HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-talk wr h = do+	(XmlNode -> Bool) -> (TVar (Maybe h)) -> (TVar (Maybe h)) ->+	(TVar (Maybe (String, Int, FilePath))) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Maybe (HandleMonad h h) ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+talk wr vh vch vhi gc mgs = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan-	void . liftBaseDiscard forkIO . runPipe_ . forever $ do-		req <- lift $ getRequest h-		requestBody req-			=$= xmlEvent-			=$= convert fromJust-			=$= xmlNode []-			=$= checkReply wr otc-			=$= toTChan inc-		fromTChan otc =$= await >>= maybe (return ()) (\mn ->-			lift . putResponse h . responseP $ case mn of-				Just n -> LBS.fromChunks [xmlString [n]]-				_ -> "")+	void . liftBaseDiscard forkIO $ do+		flip (maybe (return ())) mgs $ \gs -> do+			h <- gs+			liftBase . atomically $ writeTVar vh (Just h)+		h <- liftBase . atomically $ do+			mh <- readTVar vh+			case mh of+				Just h -> return h+				_ -> retry+		runPipe_ . forever $ do+			req <- lift $ getRequest h+			requestBody req+				=$= xmlEvent+				=$= convert fromJust+				=$= xmlNode []+				=$= setClient vch vhi gc+				=$= checkReply wr otc+				=$= toTChan inc+			fromTChan otc =$= await >>= maybe (return ()) (\mn ->+				lift . putResponse h . responseP $ case mn of+					Just n -> LBS.fromChunks [xmlString [n]]+					_ -> "") 	return (inc, otc)++setClient :: (MonadBase IO (HandleMonad h)) =>+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Pipe XmlNode XmlNode (HandleMonad h) ()+setClient vch vhi gc = (await >>=) . maybe (return ()) $ \n -> do+	yield n+	case gc n of+		Just (gh, hn, pn, pt) -> do+			h <- lift gh+			lift . liftBase . atomically . writeTVar vch $ Just h+			lift . liftBase . atomically . writeTVar vhi+				$ Just (hn, pn, pt)+		_ -> return ()+	setClient vch vhi gc
src/Network/XmlPush/HttpPush/Common.hs view
@@ -24,9 +24,10 @@ import qualified Data.ByteString.Lazy as LBS  data HttpPushArgs h = HttpPushArgs {-	hostName :: String,-	portNumber :: Int,-	basePath :: FilePath,+	getClient :: XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath),+--	getClient :: XmlNode -> Maybe (HandleMonad h h),+	getServer :: Maybe (HandleMonad h h),+	hostName :: Maybe (String, Int, FilePath), 	getPath :: XmlNode -> FilePath, 	youNeedResponse :: XmlNode -> Bool 	}
src/Network/XmlPush/HttpPush/Tls.hs view
@@ -74,59 +74,91 @@ 			(const True, clientWriteChan hp) ]  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)+	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-	when (dn /= hn) $ error "makeHttpPushTls: conflicted domain name"+	vch <- liftBase . atomically $ newTVar mch+	vsh <- liftBase . atomically $ newTVar msh+	case hi of+		Just (hn, _, _) -> when (dn /= hn) $+			error "makeHttpPushTls: conflicted domain name"+		_ -> return () 	v <- liftBase . atomically $ newTVar False-	(ci, co) <- clientC ch hn pn pt gp cs ca kcs-	(si, so) <- talk wr sh gn cc cs' mca' kcs'+	vhi <- liftBase . atomically $ newTVar hi+	(ci, co) <- clientC vch vhi 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)) =>-	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> FilePath) -> 	[Cl.CipherSuite] -> CertificateStore -> 	[(CertSecretKey, CertificateChain)] -> 	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-clientC h hn pn pt gp cs ca kcs = do+clientC vh vhi gp cs ca kcs = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan 	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool-	void . liftBaseDiscard forkIO . (`Cl.run` g) $ do-		t <- Cl.open' h hn cs kcs ca-		runPipe_ $ fromTChan otc-			=$= filter isJust-			=$= convert fromJust-			=$= clientLoop t hn pn pt gp-			=$= convert (, False)-			=$= toTChan inc+	void . liftBaseDiscard forkIO $ do+		h <- liftBase . atomically $ do+			mh <- readTVar vh+			case mh of+				Just h -> return h+				_ -> retry+		(hn, pn, pt) <- liftBase . atomically $ do+			mhi <- readTVar vhi+			case mhi of+				Just hi -> return hi+				_ -> retry+		(`Cl.run` g) $ do+			t <- Cl.open' h hn cs kcs ca+			runPipe_ $ fromTChan otc+				=$= filter isJust+				=$= convert fromJust+				=$= clientLoop t hn pn pt gp+				=$= convert (, False)+				=$= toTChan inc 	return (inc, otc)  talk :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	(XmlNode -> Bool) -> h -> (XmlNode -> Maybe String) ->+	(XmlNode -> Bool) -> (TVar (Maybe h)) -> (XmlNode -> Maybe String) -> 	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Sv.CipherSuite] -> 	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] ->+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Maybe (HandleMonad h h) -> 	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-talk wr h gn cc cs mca kcs = do+talk wr vh gn cc cs mca kcs vch vhi gc mgs = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan 	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)-	void . liftBaseDiscard forkIO . (`Sv.run` g) $ do-		t <- Sv.open h cs kcs mca-		runPipe_ . forever $ do-			req <- lift $ getRequest t-			requestBody req-				=$= xmlEvent-				=$= convert fromJust-				=$= xmlNode []-				=$= checkCert t cc-				=$= checkName t gn-				=$= checkReply wr otc-				=$= toTChan inc-			fromTChan otc =$= await >>= maybe (return ()) (\mn ->-				lift . putResponse t . responseP $ case mn of-					Just n -> LBS.fromChunks [xmlString [n]]-					_ -> "")+	void . liftBaseDiscard forkIO $ do+		flip (maybe (return ())) mgs $ \gs -> do+			h <- gs+			liftBase . atomically $ writeTVar vh (Just h)+		h <- liftBase . atomically $ do+			mh <- readTVar vh+			case mh of+				Just h -> return h+				_ -> retry+		(`Sv.run` g) $ do+			t <- Sv.open h cs kcs mca+			runPipe_ . forever $ do+				req <- lift $ getRequest t+				requestBody req+					=$= xmlEvent+					=$= convert fromJust+					=$= xmlNode []+					=$= setClient vch vhi gc+					=$= checkCert t cc+					=$= checkName t gn+					=$= checkReply wr otc+					=$= toTChan inc+				fromTChan otc =$= await >>= maybe (return ()) (\mn ->+					lift . putResponse t . responseP $ case mn of+						Just n -> LBS.fromChunks [xmlString [n]]+						_ -> "") 	return (inc, otc)  checkCert :: HandleLike h => Sv.TlsHandle h g ->@@ -151,3 +183,18 @@ svCheckName t n = do 	ns <- Sv.getNames t 	return $ n `elem` ns++setClient :: (MonadBase IO (HandleMonad h)) =>+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Pipe XmlNode XmlNode (Sv.TlsM h g) ()+setClient vch vhi gc = (await >>=) . maybe (return ()) $ \n -> do+	yield n+	case gc n of+		Just (gh, hn, pn, pt) -> do+			h <- lift . lift $ lift gh+			lift . liftBase . atomically . writeTVar vch $ Just h+			lift . liftBase . atomically . writeTVar vhi+				$ Just (hn, pn, pt)+		_ -> return ()+	setClient vch vhi gc
xml-push.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.6+version:	0.0.0.7 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.6+    tag:	xml-push-0.0.0.7  library     hs-source-dirs:	src