xml-push 0.0.0.4 → 0.0.0.5

raw patch · 6 files changed

+38/−16 lines, 6 files

Files

• examples/httpPullSv.hs +5/−1
• examples/httpPullTlsSv.hs +5/−1
• src/Network/XmlPush/HttpPull/Server.hs +2/−2
• src/Network/XmlPush/HttpPull/Server/Common.hs +22/−8
• src/Network/XmlPush/HttpPull/Tls/Server.hs +2/−2
• xml-push.cabal +2/−2

@@ -16,7 +16,7 @@ 		(h, _, _) <- accept soc 		void . forkIO $ testPusher 			(undefined :: HttpPullSv Handle) (One h)-			(HttpPullSvArgs isPll endPoll)+			(HttpPullSvArgs isPll endPoll needResponse)  isPll :: XmlNode -> Bool isPll (XmlNode (_, "poll") _ _ _) = True@@ -24,3 +24,7 @@  endPoll :: XmlNode endPoll = XmlNode (nullQ "nothing") [] [] []++needResponse :: XmlNode -> Bool+needResponse (XmlNode (_, "monologue") _ _ _) = False+needResponse _ = True

@@ -22,7 +22,7 @@ 		(h, _, _) <- accept soc 		void . forkIO $ testPusher (undefined :: HttpPullTlsSv Handle) 			(One h) (HttpPullTlsSvArgs-				(HttpPullSvArgs isPll endPoll)+				(HttpPullSvArgs isPll endPoll needResponse) 				(TlsArgs gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"] 					(Just ca) [(k, c)])) @@ -36,3 +36,7 @@ gtNm :: XmlNode -> Maybe String gtNm (XmlNode (_, "name") _ _ [XmlCharData n]) = Just $ BSC.unpack n gtNm _ = Nothing++needResponse :: XmlNode -> Bool+needResponse (XmlNode (_, "monologue") _ _ _) = False+needResponse _ = True

@@ -26,6 +26,6 @@  makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) => 	One h -> HttpPullSvArgs h -> HandleMonad h (HttpPullSv h)-makeHttpPull (One h) (HttpPullSvArgs ip ep) = do-	(inc, otc) <- runXml h ip ep (convert id)+makeHttpPull (One h) (HttpPullSvArgs ip ep ynr) = do+	(inc, otc) <- runXml h ip ep ynr (convert id) 	return $ HttpPullSv (fromTChan inc) (toTChan otc)

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, PackageImports #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}  module Network.XmlPush.HttpPull.Server.Common (HttpPullSvArgs(..), runXml) where @@ -20,24 +20,25 @@  data HttpPullSvArgs h = HttpPullSvArgs { 	isPoll :: XmlNode -> Bool,-	noPending :: XmlNode+	noPending :: XmlNode,+	youNeedResponse :: XmlNode -> Bool 	}  runXml :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	h -> (XmlNode -> Bool) -> XmlNode ->+	h -> (XmlNode -> Bool) -> XmlNode -> (XmlNode -> Bool) -> 	Pipe XmlNode XmlNode (HandleMonad h) () -> 	HandleMonad h (TChan XmlNode, TChan XmlNode)-runXml h ip ep cn = do+runXml h ip ep ynr cn = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan-	_ <- liftBaseDiscard forkIO . runPipe_ $ talk h ip ep inc otc cn+	_ <- liftBaseDiscard forkIO . runPipe_ $ talk h ip ep ynr inc otc cn 	return (inc, otc)  talk :: (HandleLike h, MonadBase IO (HandleMonad h)) =>-	h -> (XmlNode -> Bool) -> XmlNode ->+	h -> (XmlNode -> Bool) -> XmlNode -> (XmlNode -> Bool) -> 	TChan XmlNode -> TChan XmlNode -> Pipe XmlNode XmlNode (HandleMonad h) () -> 	Pipe () () (HandleMonad h) ()-talk h ip ep inc otc cn = do+talk h ip ep ynr inc otc cn = do 	r <- lift $ getRequest h 	lift . liftBase . print $ requestPath r 	rns <- requestBody r@@ -46,6 +47,18 @@ 		=$= xmlNode [] 		=$= cn 		=$= toList+	case rns of+		[rn]	| ip rn -> (flushOr otc ep =$=) . (await >>=)+				. maybe (return ()) $ \n -> lift . putResponse h+					. responseP $ LBS.fromChunks [xmlString [n]]+			| not $ ynr rn -> do+				mapM_ yield rns =$= toTChan inc+				lift . putResponse h $ responseP ""+		_ -> do	mapM_ yield rns =$= toTChan inc+			(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]]@@ -53,7 +66,8 @@ 		(fromTChan otc =$=) . (await >>=) . maybe (return ()) $ \n -> 			lift . putResponse h . responseP 				$ LBS.fromChunks [xmlString [n]]-	talk h ip ep inc otc cn+				-}+	talk h ip ep ynr inc otc cn  responseP :: (HandleLike h, MonadBase IO (HandleMonad h)) => 	LBS.ByteString -> Response Pipe h

@@ -39,11 +39,11 @@ makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => 	One h -> HttpPullTlsSvArgs h -> HandleMonad h (HttpPullTlsSv h) makeHttpPull (One h) (HttpPullTlsSvArgs-	(HttpPullSvArgs ip ep) (TlsArgs gn cs mca kcs)) = do+	(HttpPullSvArgs ip ep ynr) (TlsArgs gn 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 $ checkNameP t gn+		runXml t ip ep ynr $ checkNameP t gn 	return $ HttpPullTlsSv (fromTChan inc) (toTChan otc)  checkNameP :: HandleLike h => TlsHandle h g -> (XmlNode -> Maybe String) ->

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.4+version:	0.0.0.5 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.4+    tag:	xml-push-0.0.0.5  library     hs-source-dirs:	src