module Network.XmlPush.HttpPush.Common (
HttpPushArgs(..),
setNeedReply,
clientLoop,
checkReply,
responseP,
) where
import Control.Monad
import "monads-tf" Control.Monad.Trans
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Concurrent.STM
import Data.Maybe
import Data.HandleLike
import Data.Pipe
import Text.XML.Pipe
import Network.TigHTTP.Client
import Network.TigHTTP.Server
import Network.TigHTTP.Types
import qualified Data.ByteString.Lazy as LBS
data HttpPushArgs h = HttpPushArgs {
getClient :: XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath),
getServer :: Maybe (HandleMonad h h),
hostName :: Maybe (String, Int, FilePath),
getPath :: XmlNode -> FilePath,
youNeedResponse :: XmlNode -> Bool
}
setNeedReply :: MonadBase IO m => TVar Bool -> Pipe (a, Bool) a m ()
setNeedReply nr = await >>= maybe (return ()) (\(x, b) ->
lift (liftBase . atomically $ writeTVar nr b) >> yield x >> setNeedReply nr)
clientLoop :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>
h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->
Pipe XmlNode XmlNode (HandleMonad h) () ->
Pipe XmlNode XmlNode (HandleMonad h) ()
clientLoop h hn pn pt gp p = (await >>=) . maybe (return ()) $ \n -> do
r <- lift . request h $ post hn pn (pt ++ "/" ++ gp n)
(Nothing, LBS.fromChunks [xmlString [n]])
return ()
=$= responseBody r
=$= xmlEvent
=$= convert fromJust
=$= void (xmlNode [])
=$= p
clientLoop h hn pn pt gp p
checkReply :: MonadBase IO m => (XmlNode -> Bool) -> TChan (Maybe XmlNode) ->
Pipe XmlNode (XmlNode, Bool) m ()
checkReply wr o = (await >>=) . maybe (return ()) $ \n ->
if wr n
then yield (n, True) >> checkReply wr o
else do lift (liftBase . atomically $ writeTChan o Nothing)
yield (n, False)
checkReply wr o
responseP :: HandleLike h => LBS.ByteString -> Response Pipe h
responseP = response