diff --git a/src/Network/XmlPush/Http/Server.hs b/src/Network/XmlPush/Http/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XmlPush/Http/Server.hs
@@ -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
diff --git a/src/Network/XmlPush/HttpPull/Client/Common.hs b/src/Network/XmlPush/HttpPull/Client/Common.hs
--- a/src/Network/XmlPush/HttpPull/Client/Common.hs
+++ b/src/Network/XmlPush/HttpPull/Client/Common.hs
@@ -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
diff --git a/src/Network/XmlPush/HttpPull/Server.hs b/src/Network/XmlPush/HttpPull/Server.hs
--- a/src/Network/XmlPush/HttpPull/Server.hs
+++ b/src/Network/XmlPush/HttpPull/Server.hs
@@ -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
diff --git a/src/Network/XmlPush/HttpPull/Server/Body.hs b/src/Network/XmlPush/HttpPull/Server/Body.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XmlPush/HttpPull/Server/Body.hs
@@ -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
diff --git a/src/Network/XmlPush/HttpPull/Server/Common.hs b/src/Network/XmlPush/HttpPull/Server/Common.hs
--- a/src/Network/XmlPush/HttpPull/Server/Common.hs
+++ b/src/Network/XmlPush/HttpPull/Server/Common.hs
@@ -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)) =>
diff --git a/src/Network/XmlPush/HttpPull/Tls/Server.hs b/src/Network/XmlPush/HttpPull/Tls/Server.hs
--- a/src/Network/XmlPush/HttpPull/Tls/Server.hs
+++ b/src/Network/XmlPush/HttpPull/Tls/Server.hs
@@ -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)
 
 {-
diff --git a/src/Network/XmlPush/HttpPush.hs b/src/Network/XmlPush/HttpPush.hs
--- a/src/Network/XmlPush/HttpPush.hs
+++ b/src/Network/XmlPush/HttpPush.hs
@@ -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
diff --git a/src/Network/XmlPush/HttpPush/Body.hs b/src/Network/XmlPush/HttpPush/Body.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XmlPush/HttpPush/Body.hs
@@ -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
diff --git a/xml-push.cabal b/xml-push.cabal
--- a/xml-push.cabal
+++ b/xml-push.cabal
@@ -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.*,