packages feed

xml-push 0.0.0.13 → 0.0.0.14

raw patch · 9 files changed

+319/−172 lines, 9 files

Files

+ src/Network/XmlPush/Http/Server.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.XmlPush.Http.Server (+	HttpSv,+	HttpSvArgs(..), Mechanism(..),+	HttpPullSvArgs(HttpPullSvArgs), HttpPushArgs(HttpPushArgs),+	) where++import Control.Monad+import "monads-tf" Control.Monad.Error+-- import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.List+import Text.XML.Pipe+import Network.XmlPush+import Network.XmlPush.HttpPull.Server.Body+import Network.XmlPush.HttpPush.Body+import Network.TigHTTP.Server+import Network.Sasl+import Network.PeyoTLS.Server++newtype HttpSv h = HttpSv (Either (HttpPullSv h) (HttpPush h))++data Mechanism = Pull | Push deriving Show++data HttpSvArgs h =+	HttpSvArgs (XmlNode -> Mechanism) (HttpPullSvArgs h) (HttpPushArgs h)++instance XmlPusher HttpSv where+	type NumOfHandle HttpSv = Two+	type PusherArgs HttpSv = HttpSvArgs+	generate (Two ch (Just sh)) (HttpSvArgs s pla psa) =+		makeHttpSv ch sh s pla psa+	generate _ _ = error "bad"+	readFrom (HttpSv e) = either readFrom readFrom e+	writeTo (HttpSv e) = either writeTo writeTo e++makeHttpSv :: (+	ValidateHandle h, MonadBaseControl IO (HandleMonad h),+	MonadError (HandleMonad h), SaslError (ErrorType (HandleMonad h))+	) => Maybe h -> h -> (XmlNode -> Mechanism) ->+	HttpPullSvArgs h -> HttpPushArgs h -> HandleMonad h (HttpSv h)+makeHttpSv ch sh s pla psa = do+	rq <- getRequest sh+--	liftBase . print $ requestPath r+	Just [rn] <- runPipe $ requestBody rq+		=$= xmlEvent+		=$= convert fromJust+		=$= xmlNode []+		=$= toList+--	liftBase . putStrLn $ "here"+	HttpSv `liftM` case s rn of+		Pull -> do+			HttpPullSvTest r w <- generate (One sh) $+				HttpPullSvTestArgs pla [rn]+--				HttpPullSvTestArgs pla []+			return . Left $ HttpPullSv r w+		Push -> do+			HttpPushTest ps <- generate (Two ch (Just sh)) $+				HttpPushTestArgs psa [rn]+			return $ Right ps
src/Network/XmlPush/HttpPull/Client/Common.hs view
@@ -14,6 +14,7 @@ import Data.Maybe import Data.HandleLike import Data.Pipe+-- import Data.Pipe.IO import Data.Pipe.TChan import System.IO import Text.XML.Pipe@@ -39,6 +40,7 @@ 	TVar (Maybe Int) -> (XmlNode -> Maybe Int) -> 	HandleMonad h (TChan XmlNode, TChan XmlNode) talkC h addr pn pth gp pl ip dr gdr = do+--	liftBase $ putStrLn "talkC begin" 	lock <- liftBase $ atomically newTChan 	liftBase . atomically $ writeTChan lock () 	inc <- liftBase $ atomically newTChan@@ -46,7 +48,9 @@ 	otc <- liftBase $ atomically newTChan 	otc' <- liftBase $ atomically newTChan 	void . liftBaseDiscard forkIO . runPipe_ $ fromTChan otc+--		=$= debug 		=$= conversation lock h addr pn pth gp dr gdr+--		=$= debug 		=$= toTChan inc 	void . liftBaseDiscard forkIO . runPipe_ $ fromTChan otc' 		=$= conversation lock h addr pn pth gp dr gdr@@ -60,6 +64,7 @@ 		liftBase $ threadDelay d 		p <- pl 		liftBase $ polling p ip inc' inc otc'+--	liftBase $ putStrLn "talkC end" 	return (inc, otc)  conversation :: (HandleLike h, MonadBase IO (HandleMonad h)) =>@@ -91,12 +96,16 @@ 	Pipe XmlNode XmlNode (HandleMonad h) () talk lock h addr pn pth gp = (await >>=) . maybe (return ()) $ \n -> do 	let m = LBS.fromChunks [xmlString [n]]+--	lift . liftBase $ putStrLn "before lock" 	lift . liftBase . atomically $ readTChan lock+--	lift . liftBase $ putStrLn "locking" 	r <- lift . request h $ post addr pn (pth ++ "/" ++ gp n) (Nothing, m)+--	lift . liftBase $ putStrLn "request done" 	void $ return () 		=$= responseBody r 		=$= xmlEvent 		=$= convert fromJust 		=$= xmlNode [] 	lift . liftBase . atomically $ writeTChan lock ()+--	lift . liftBase $ putStrLn "after lock" 	talk lock h addr pn pth gp
src/Network/XmlPush/HttpPull/Server.hs view
@@ -2,30 +2,4 @@  module Network.XmlPush.HttpPull.Server (HttpPullSv, HttpPullSvArgs(..)) where -import Prelude hiding (filter)--import Control.Monad.Trans.Control-import Data.HandleLike-import Data.Pipe-import Data.Pipe.TChan-import Text.XML.Pipe--import Network.XmlPush-import Network.XmlPush.HttpPull.Server.Common--data HttpPullSv h = HttpPullSv-	(Pipe () XmlNode (HandleMonad h) ())-	(Pipe XmlNode () (HandleMonad h) ())--instance XmlPusher HttpPullSv where-	type NumOfHandle HttpPullSv = One-	type PusherArgs HttpPullSv = HttpPullSvArgs-	generate = makeHttpPull-	readFrom (HttpPullSv r _) = r-	writeTo (HttpPullSv _ w) = w--makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	One h -> HttpPullSvArgs h -> HandleMonad h (HttpPullSv h)-makeHttpPull (One h) (HttpPullSvArgs ip ep ynr) = do-	(inc, otc) <- runXml h ip ep ynr (convert id)-	return $ HttpPullSv (fromTChan inc) (toTChan otc)+import Network.XmlPush.HttpPull.Server.Body
+ src/Network/XmlPush/HttpPull/Server/Body.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts #-}++module Network.XmlPush.HttpPull.Server.Body (+	HttpPullSv(..), HttpPullSvArgs(..), makeHttpPull,+	HttpPullSvTest(..), HttpPullSvTestArgs(..),+	) where++import Prelude hiding (filter)++import Control.Monad.Trans.Control+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import Text.XML.Pipe++import Network.XmlPush+import Network.XmlPush.HttpPull.Server.Common++data HttpPullSv h = HttpPullSv+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher HttpPullSv where+	type NumOfHandle HttpPullSv = One+	type PusherArgs HttpPullSv = HttpPullSvArgs+	generate = makeHttpPull []+	readFrom (HttpPullSv r _) = r+	writeTo (HttpPullSv _ w) = w++makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] -> One h -> HttpPullSvArgs h -> HandleMonad h (HttpPullSv h)+makeHttpPull pre (One h) (HttpPullSvArgs ip ep ynr) = do+--	hlDebug h "critical" "begin makeHttpPull\n"+	(inc, otc) <- runXml pre h ip ep ynr (convert id)+--	hlDebug h "critical" "runXml done\n"+	return $ HttpPullSv (fromTChan inc) (toTChan otc)++data HttpPullSvTest h = HttpPullSvTest+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++data HttpPullSvTestArgs h = HttpPullSvTestArgs (HttpPullSvArgs h) [XmlNode]++instance XmlPusher HttpPullSvTest where+	type NumOfHandle HttpPullSvTest = One+	type PusherArgs HttpPullSvTest = HttpPullSvTestArgs+	generate h (HttpPullSvTestArgs a pre) = do+		HttpPullSv r w <- makeHttpPull pre h a+		return $ HttpPullSvTest r w+	readFrom (HttpPullSvTest r _) = r+	writeTo (HttpPullSvTest _ w) = w
src/Network/XmlPush/HttpPull/Server/Common.hs view
@@ -25,22 +25,36 @@ 	}  runXml :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] -> 	h -> (XmlNode -> Bool) -> XmlNode -> (XmlNode -> Bool) -> 	Pipe XmlNode XmlNode (HandleMonad h) () -> 	HandleMonad h (TChan XmlNode, TChan XmlNode)-runXml h ip ep ynr cn = do+runXml pre h ip ep ynr cn = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan-	_ <- liftBaseDiscard forkIO . runPipe_ $ talk h ip ep ynr inc otc cn+	_ <- liftBaseDiscard forkIO . runPipe_ $ do+		writeToChan h inc otc pre cn+		talk h ip ep ynr inc otc cn 	return (inc, otc) +writeToChan :: (HandleLike h, MonadBase IO (HandleMonad h)) => h ->+	TChan XmlNode -> TChan XmlNode ->+	[XmlNode] -> Pipe XmlNode XmlNode (HandleMonad h) () ->+	Pipe () () (HandleMonad h) ()+writeToChan h inc otc pre cn = do+	mapM yield pre =$= cn =$= toTChan inc+	(fromTChan otc =$=) . (await >>=) . maybe (return ()) $ \n ->+		lift . putResponse h . responseP $ LBS.fromChunks [xmlString [n]]+ talk :: (HandleLike h, MonadBase IO (HandleMonad h)) => 	h -> (XmlNode -> Bool) -> XmlNode -> (XmlNode -> Bool) -> 	TChan XmlNode -> TChan XmlNode -> Pipe XmlNode XmlNode (HandleMonad h) () -> 	Pipe () () (HandleMonad h) () talk h ip ep ynr inc otc cn = do+--	lift . liftBase $ putStrLn "talk begin" 	r <- lift $ getRequest h-	lift . liftBase . print $ requestPath r+--	lift . liftBase $ putStrLn "getRequest done"+--	lift . liftBase . print $ requestPath r 	rns <- requestBody r 		=$= xmlEvent 		=$= convert fromJust@@ -58,15 +72,6 @@ 			(fromTChan otc =$=) . (await >>=) . maybe (return ()) $ 				\n -> lift . putResponse h . responseP 					$ LBS.fromChunks [xmlString [n]]-		{--	if case rns of [n] -> ip n; _ -> False-	then (flushOr otc ep =$=) . (await >>=) . maybe (return ()) $ \n ->-		lift . putResponse h . responseP $ LBS.fromChunks [xmlString [n]]-	else do	mapM_ yield rns =$= toTChan inc-		(fromTChan otc =$=) . (await >>=) . maybe (return ()) $ \n ->-			lift . putResponse h . responseP-				$ LBS.fromChunks [xmlString [n]]-				-} 	talk h ip ep ynr inc otc cn  responseP :: (HandleLike h, MonadBase IO (HandleMonad h)) =>
src/Network/XmlPush/HttpPull/Tls/Server.hs view
@@ -56,7 +56,7 @@ 			. toHexStr 			. flip getFingerprint HashSHA256 			-}-		runXml t ip ep ynr $ checkNameP t gn cc+		runXml [] t ip ep ynr $ checkNameP t gn cc 	return $ HttpPullTlsSv (fromTChan inc) (toTChan otc)  {-
src/Network/XmlPush/HttpPush.hs view
@@ -1,132 +1,3 @@-{-# LANGUAGE OverloadedStrings, TupleSections, TypeFamilies, FlexibleContexts,-	PackageImports #-}- module Network.XmlPush.HttpPush (HttpPush, HttpPushArgs(..)) where -import Prelude hiding (filter)--import Control.Monad-import "monads-tf" Control.Monad.Trans-import Control.Monad.Base-import Control.Monad.Trans.Control-import Control.Concurrent hiding (yield)-import Control.Concurrent.STM-import Data.Maybe-import Data.HandleLike-import Data.Pipe-import Data.Pipe.Flow-import Data.Pipe.TChan-import Text.XML.Pipe-import Network.TigHTTP.Server--import qualified Data.ByteString.Lazy as LBS--import Network.XmlPush-import Network.XmlPush.HttpPush.Common--data HttpPush h = HttpPush {-	needReply :: TVar Bool,-	clientReadChan :: TChan (XmlNode, Bool),-	clientWriteChan :: TChan (Maybe XmlNode),-	serverReadChan :: TChan (XmlNode, Bool),-	serverWriteChan :: TChan (Maybe XmlNode) }--instance XmlPusher HttpPush where-	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 [serverReadChan hp, clientReadChan hp] =$=-		setNeedReply (needReply hp)-	writeTo hp = (convert ((() ,) . Just) =$=) . toTChansM $ do-		nr <- liftBase . atomically . readTVar $ needReply hp-		liftBase . atomically $ writeTVar (needReply hp) False-		return [-			(const nr, serverWriteChan hp),-			(const True, clientWriteChan hp) ]--makeHttpPush :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	(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-	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)) =>-	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->-	(XmlNode -> FilePath) ->-	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-clientC vh vhi gp = do-	inc <- liftBase $ atomically newTChan-	otc <- liftBase $ atomically newTChan-	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 id)-			=$= convert (, False)-			=$= toTChan inc-	return (inc, otc)--talk :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	(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 $ 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+import Network.XmlPush.HttpPush.Body
+ src/Network/XmlPush/HttpPush/Body.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings, TupleSections, TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.HttpPush.Body (+	HttpPush, HttpPushArgs(..), makeHttpPush,+	HttpPushTest(..), HttpPushTestArgs(..),+	) where++import Prelude hiding (filter)++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.TigHTTP.Server++import qualified Data.ByteString.Lazy as LBS++import Network.XmlPush+import Network.XmlPush.HttpPush.Common++data HttpPush h = HttpPush {+	needReply :: TVar Bool,+	clientReadChan :: TChan (XmlNode, Bool),+	clientWriteChan :: TChan (Maybe XmlNode),+	serverReadChan :: TChan (XmlNode, Bool),+	serverWriteChan :: TChan (Maybe XmlNode) }++instance XmlPusher HttpPush where+	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 [serverReadChan hp, clientReadChan hp] =$=+		setNeedReply (needReply hp)+	writeTo hp = (convert ((() ,) . Just) =$=) . toTChansM $ do+		nr <- liftBase . atomically . readTVar $ needReply hp+		liftBase . atomically $ writeTVar (needReply hp) False+		return [+			(const nr, serverWriteChan hp),+			(const True, clientWriteChan hp) ]++data HttpPushTest h = HttpPushTest (HttpPush h)+data HttpPushTestArgs h = HttpPushTestArgs (HttpPushArgs h) [XmlNode]++instance XmlPusher HttpPushTest where+	type NumOfHandle HttpPushTest = Two+	type PusherArgs HttpPushTest = HttpPushTestArgs+	generate (Two ch sh) (HttpPushTestArgs a p) =+		HttpPushTest <$> makeHttpPush p ch sh a+--	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=+	readFrom (HttpPushTest hp) = fromTChans [serverReadChan hp, clientReadChan hp] =$=+		setNeedReply (needReply hp)+	writeTo (HttpPushTest hp) = (convert ((() ,) . Just) =$=) . toTChansM $ do+		nr <- liftBase . atomically . readTVar $ needReply hp+		liftBase . atomically $ writeTVar (needReply hp) False+		return [+			(const nr, serverWriteChan hp),+			(const True, clientWriteChan hp) ]++makeHttpPush :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] ->+	(Maybe h) -> (Maybe h) ->+	HttpPushArgs h -> HandleMonad h (HttpPush h)+makeHttpPush pre mch msh (HttpPushArgs gc gs hi gp wr) = do+	vch <- liftBase . atomically $ newTVar mch+	vsh <- liftBase . atomically $ newTVar msh+	v <- liftBase . atomically $ newTVar False+	vhi <- liftBase . atomically $ newTVar hi+	(ci, co) <- clientC vch vhi gp+	(si, so) <- talk pre wr vsh vch vhi gc gs+	return $ HttpPush v ci co si so++clientC :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> FilePath) ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+clientC vh vhi gp = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	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 id)+			=$= convert (, False)+			=$= toTChan inc+	return (inc, otc)++talk :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] ->+	(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 pre wr vh vch vhi gc mgs = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	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_ . writeToChan h inc otc pre $+			setClient vch vhi gc =$= checkReply wr otc+		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)++writeToChan :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+	h -> TChan a -> TChan (Maybe XmlNode) -> [XmlNode] ->+	Pipe XmlNode a (HandleMonad h) () ->+	Pipe () () (HandleMonad h) ()+writeToChan _ _ _ [] _ = return ()+writeToChan h inc otc pre pp = do+	mapM yield pre =$= pp =$= toTChan inc+	fromTChan otc =$= await >>= maybe (return ()) (\mn ->+		lift . putResponse h . responseP $ case mn of+			Just n -> LBS.fromChunks [xmlString [n]]+			_ -> "")++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
xml-push.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.13+version:	0.0.0.14 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.13+    tag:	xml-push-0.0.0.14  library     hs-source-dirs:	src@@ -111,6 +111,7 @@         Network.XmlPush.HttpPull.Client, Network.XmlPush.HttpPull.Server         Network.XmlPush.HttpPull.Tls.Client, Network.XmlPush.HttpPull.Tls.Server         Network.XmlPush.HttpPush, Network.XmlPush.HttpPush.Tls+        Network.XmlPush.Http.Server     other-modules:         Network.XmlPush.Tls.Client         Network.XmlPush.Tls.Server@@ -118,7 +119,9 @@         Network.XmlPush.Xmpp.Server.Common         Network.XmlPush.HttpPull.Client.Common         Network.XmlPush.HttpPull.Server.Common+        Network.XmlPush.HttpPull.Server.Body         Network.XmlPush.HttpPush.Common+        Network.XmlPush.HttpPush.Body     build-depends:         base == 4.*, peyotls == 0.1.*, simple-pipe == 0.0.*, xml-pipe == 0.0.*,         handle-like == 0.1.*, monad-control == 0.3.*, transformers-base == 0.4.*,