xml-push 0.0.0.16 → 0.0.0.17
raw patch · 8 files changed
+73/−27 lines, 8 files
Files
- examples/TestPusher.hs +4/−2
- examples/xmppTls.hs +1/−0
- src/Network/XmlPush/Http/Tls/Server.hs +1/−1
- src/Network/XmlPush/HttpPull/Server/Common.hs +19/−8
- src/Network/XmlPush/HttpPush/Common.hs +14/−2
- src/Network/XmlPush/HttpPush/Tls/Body.hs +22/−7
- src/Network/XmlPush/Xmpp/Tls.hs +10/−5
- xml-push.cabal +2/−2
examples/TestPusher.hs view
@@ -10,6 +10,7 @@ import Data.Maybe import Data.List import Data.Char+import Data.HandleLike import Data.Pipe import Data.Pipe.ByteString import Data.X509@@ -17,13 +18,14 @@ import System.IO import Text.XML.Pipe import Numeric+import Network.PeyoTLS.Client (ValidateHandle) import qualified Data.ByteString as BS import Network.XmlPush -testPusher :: XmlPusher xp =>- xp Handle -> NumOfHandle xp Handle -> PusherArgs xp Handle -> IO ()+testPusher :: (XmlPusher xp, ValidateHandle h, HandleMonad h ~ IO) =>+ xp h -> NumOfHandle xp h -> PusherArgs xp h -> IO () testPusher tp hs as = do xp <- (`asTypeOf` tp) <$> generate hs as void . forkIO . runPipe_ $ readFrom xp
examples/xmppTls.hs view
@@ -21,6 +21,7 @@ k <- readKey "certs/yoshikuni.sample_key" c <- readCertificateChain ["certs/yoshikuni.sample_crt"] testPusher (undefined :: XmppTls Handle) (One h) (XmppTlsArgs+ True (XmppArgs ["EXTERNAL", "SCRAM-SHA-1", "DIGEST-MD5", "PLAIN"] (toJid me) ps (toJid you) iNdRspns wntRspns) (TlsArgs "localhost" True (const Nothing)
src/Network/XmlPush/Http/Tls/Server.hs view
@@ -66,7 +66,7 @@ HttpPullTlsSv r w <- makeHttpPull [rn] t pla' gn cc return . Left $ HttpPullTlsSv r w Push -> do- hlDebug t "critical" "PUSH\n"+ hlDebug t "medium" "PUSH\n" ps <- makeHttpPush [rn] ch t $ HttpPushTlsArgs psa' tlsC tlsS return $ Right ps
src/Network/XmlPush/HttpPull/Server/Common.hs view
@@ -16,6 +16,7 @@ import Network.TigHTTP.Server import Network.TigHTTP.Types +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS data HttpPullSvArgs h = HttpPullSvArgs {@@ -51,27 +52,37 @@ 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 $ putStrLn "getRequest done"--- lift . liftBase . print $ requestPath r rns <- requestBody r =$= xmlEvent =$= convert fromJust =$= xmlNode [] =$= cn =$= toList+ lift . hlDebug h "medium" $+ "\nxml-push: in: " `BS.append` xmlString rns `BS.append` "\n" case rns of [rn] | ip rn -> (flushOr otc ep =$=) . (await >>=)- . maybe (return ()) $ \n -> lift . putResponse h- . responseP $ LBS.fromChunks [xmlString [n]]+ . maybe (return ()) $ \n -> lift $ do+ let rt = xmlString [n]+ hlDebug h "medium" $ BS.concat [+ "xml-push: out:", rt, "\n" ]+ putResponse h . responseP+ $ LBS.fromChunks [rt] | not $ ynr rn -> do mapM_ yield rns =$= toTChan inc- lift . putResponse h $ responseP ""+ lift $ do+ hlDebug h "medium"+ "xml-push: out: (empty)\n"+ putResponse h $ responseP "" _ -> do mapM_ yield rns =$= toTChan inc (fromTChan otc =$=) . (await >>=) . maybe (return ()) $- \n -> lift . putResponse h . responseP- $ LBS.fromChunks [xmlString [n]]+ \n -> lift $ do+ let rt = xmlString [n]+ hlDebug h "medium" $ BS.concat [+ "xml-push: out:", rt, "\n" ]+ putResponse h . responseP+ $ LBS.fromChunks [rt] talk h ip ep ynr inc otc cn responseP :: (HandleLike h, MonadBase IO (HandleMonad h)) =>
src/Network/XmlPush/HttpPush/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, PackageImports #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-} module Network.XmlPush.HttpPush.Common ( HttpPushArgs(..),@@ -21,6 +21,7 @@ import Network.TigHTTP.Server import Network.TigHTTP.Types +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS data HttpPushArgs h = HttpPushArgs {@@ -36,18 +37,29 @@ setNeedReply nr = await >>= maybe (return ()) (\(x, b) -> lift (liftBase . atomically $ writeTVar nr b) >> yield x >> setNeedReply nr) +hlDebugP :: HandleLike h => h -> (a -> BS.ByteString) -> Pipe a a (HandleMonad h) ()+hlDebugP h shw = (await >>=) . maybe (return ()) $ \x -> do+ lift . hlDebug h "medium" $ shw x+ yield x+ hlDebugP h shw+ 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+ let rt = xmlString [n]+ lift . hlDebug h "medium" $ BS.concat+ ["xml-push: clientLoop: out: ", rt, "\n"] r <- lift . request h $ post hn pn (pt ++ "/" ++ gp n)- (Nothing, LBS.fromChunks [xmlString [n]])+ (Nothing, LBS.fromChunks [rt])+ lift $ hlDebug h "medium" "xml-push: clientLoop: in: returned\n" return () =$= responseBody r =$= xmlEvent =$= convert fromJust =$= void (xmlNode [])+ =$= hlDebugP h ((`BS.append` "\n") . xmlString . (: [])) =$= p clientLoop h hn pn pt gp p
src/Network/XmlPush/HttpPush/Tls/Body.hs view
@@ -32,6 +32,7 @@ import Network.PeyoTLS.Client (ValidateHandle) import "crypto-random" Crypto.Random +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Network.PeyoTLS.Client as Cl import qualified Network.PeyoTLS.Server as Sv@@ -114,7 +115,6 @@ (TC.TlsArgs dn cdn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do vch <- lift . lift . liftBase . atomically $ newTVar mch vsh <- lift . lift . liftBase . atomically $ newTVar undefined- hlDebug t "critical" "in makeHttpPush\n" case hi of Just (hn, _, _) -> when (dn /= hn) $ error "makeHttpPushTls: conflicted domain name"@@ -125,10 +125,8 @@ (si, so) <- do inc <- lift . lift . liftBase $ atomically newTChan otc <- lift . lift . liftBase $ atomically newTChan- hlDebug t "critical" "before talkT\n" void . liftBaseDiscard forkIO $ talkT t inc otc pre wr gn cc vch vhi gc- hlDebug t "critical" "after talkT\n" return (inc, otc) return $ HttpPushTls v ci co si so @@ -191,6 +189,12 @@ talkT t inc otc pre wr gn cc vch vhi gc return (inc, otc) +hlDebugP :: HandleLike h => h -> (a -> BS.ByteString) -> Pipe a a (HandleMonad h) ()+hlDebugP h shw = (await >>=) . maybe (return ()) $ \x -> do+ lift . hlDebug h "medium" $ shw x+ yield x+ hlDebugP h shw+ talkT :: (ValidateHandle h, MonadBase IO (HandleMonad h), CPRG g) => Sv.TlsHandle h g -> TChan (XmlNode, Bool) -> TChan (Maybe XmlNode) -> [XmlNode] -> (XmlNode -> Bool) -> (XmlNode -> Maybe String) ->@@ -210,12 +214,23 @@ =$= setClient vch vhi gc =$= checkCert t cc =$= checkName t gn+ =$= hlDebugP t ((`BS.append` "\n")+ . ("xml-push: talkT: in "+ `BS.append`)+ . xmlString . (: [])) =$= checkReply wr otc =$= toTChan inc- fromTChan otc =$= await >>= maybe (return ()) (\mn ->- lift . putResponse t . responseP $ case mn of- Just n -> LBS.fromChunks [xmlString [n]]- _ -> "")+ fromTChan otc =$= await >>= maybe (return ())+ (\mn -> do+ let rt = case mn of+ Just n -> xmlString [n]+ _ -> ""+ lift $ debugOut rt+ lift . putResponse t . responseP $+ LBS.fromChunks [rt])+ where+ debugOut rt = hlDebug t "medium" $ BS.concat [+ "xml-push: talkT: out: ", rt, "\n"] writeToChan :: (HandleLike h, MonadBase IO (HandleMonad h)) => h -> TChan a -> TChan (Maybe XmlNode) -> [XmlNode] ->
src/Network/XmlPush/Xmpp/Tls.hs view
@@ -18,6 +18,7 @@ import Data.Maybe import Data.HandleLike import Data.Pipe+import Data.Pipe.IO import Data.Pipe.Flow import Data.Pipe.TChan import Text.XML.Pipe@@ -38,7 +39,7 @@ (Pipe () Mpi (HandleMonad h) ()) (TChan (Either BS.ByteString XmlNode)) -data XmppTlsArgs h = XmppTlsArgs (XmppArgs h) TlsArgs+data XmppTlsArgs h = XmppTlsArgs Bool (XmppArgs h) TlsArgs instance XmlPusher XmppTls where type NumOfHandle XmppTls = One@@ -55,8 +56,8 @@ ValidateHandle h, MonadBaseControl IO (HandleMonad h), MonadError (HandleMonad h), Error (ErrorType (HandleMonad h)) ) => One h -> XmppTlsArgs h -> HandleMonad h (XmppTls h)-makeXmppTls (One h)- (XmppTlsArgs (XmppArgs ms me ps you inr wr) (TlsArgs dn _ _ cs ca kcs)) = do+makeXmppTls (One h) (XmppTlsArgs dbg+ (XmppArgs ms me ps you inr wr) (TlsArgs dn _ _ cs ca kcs)) = do nr <- liftBase $ atomically newTChan wc <- liftBase $ atomically newTChan (g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool@@ -73,6 +74,10 @@ =@= toTChan otc runPipe_ $ yield (Presence tagsNull []) =$= output =$= toTChan otc (>> return ()) . liftBaseDiscard forkIO . runPipe_ $ fromTChan wc- =$= addRandom =$= makeResponse inr you nr =$= output =$= toTChan otc- let r = fromTChan inc =$= input ns+ =$= addRandom =$= makeResponse inr you nr =$= output+ =$= (if dbg then debug else convert id)+ =$= toTChan otc+ let r = fromTChan inc+ =$= (if dbg then debug else convert id)+ =$= input ns return $ XmppTls wr nr r wc
xml-push.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: xml-push-version: 0.0.0.16+version: 0.0.0.17 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.16+ tag: xml-push-0.0.0.17 library hs-source-dirs: src