regarding outbound-to-peer connections: changed from socket Handle to

a ByteString sink.

1 files changed, 63 insertions, 27 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 417b3ce7..70f2905a 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -103,11 +103,11 @@ xmlifyPresenceForClient (Presence jid stat) = do
     return (concatMap presenceEvents jidstrs)
  where
     presenceEvents jidstr =
-      [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
-      , EventBeginElement "show" []
+      [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat)
+      , EventBeginElement "{jabber:client}show" []
       , EventContent (ContentText . shw $ stat)
-      , EventEndElement "show"
-      , EventEndElement "presence"
+      , EventEndElement "{jabber:client}show"
+      , EventEndElement "{jabber:client}presence"
       ]
     typ Offline = [("type",[ContentText "unavailable"])]
     typ _       = []
@@ -607,24 +607,56 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
     liftIO $ do
         h <- socketToHandle sock ReadWriteMode
         hSetBuffering h NoBuffering
-        L.hPutStrLn h "<stream>"
-        L.putStrLn $ "OUT peer: <stream>"
+        let snk = packetSink h
         cache <- fmap Map.assocs . readIORef $ cached
         writeIORef cached Map.empty -- hint garbage collector: we're done with this
-        forM_ cache $ \(jid,st) -> do
-            r <- xmlifyPresenceForPeer sock (Presence jid st)
-            L.hPutStrLn h r
-            L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n"
-        fix $ \loop -> do
-            event <- atomically $ readTChan chan
-            case event of
-              OutBoundPresence p -> do
-                r <- xmlifyPresenceForPeer sock p
-                L.hPutStrLn h r
-                L.putStrLn $ "OUT peer:\n" <++> r <++> "\n"
-            loop
-        L.hPutStrLn h "</stream>"
-        L.putStrLn $ "OUT peer: </stream>"
+        handleOutgoingToPeer (restrictSocket sock) cache chan snk
+
+
+greetPeer =
+    [ EventBeginDocument
+    , EventBeginElement (streamP "stream")
+        [("xmlns",[ContentText "jabber:server"])
+        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
+        ,("version",[ContentText "1.0"])
+        ]
+    ]
+
+goodbyePeer = 
+    [ EventEndElement "{jabber:server}stream"
+    , EventEndDocument
+    ]
+
+toPeer sock cache chan = do
+    let log  = liftIO . L.putStrLn . ("(>P) " <++>)
+    yield greetPeer
+    log "<stream>"
+    forM_ cache $ \(jid,st) -> do
+        r <- lift $ xmlifyPresenceForPeer sock (Presence jid st)
+        yield r
+        log $ "(cache) \n" <++> bshow r
+    fix $ \loop -> do
+        event <- lift . atomically $ readTChan chan
+        case event of
+          OutBoundPresence p -> do
+            r <- lift $ xmlifyPresenceForPeer sock p
+            yield r
+            log (bshow r)
+        loop
+    yield goodbyePeer
+    log "</stream>"
+
+handleOutgoingToPeer sock cache chan snk = do
+#ifdef RENDERFLUSH
+    toPeer sock cache chan 
+        $$  flushList
+        =$= renderBuilderFlush def
+        =$= builderToByteStringFlush
+        =$= discardFlush
+         =$ snk
+#else
+    toPeer sock cache chan $$ renderChunks =$ snk
+#endif
 
 connect' :: SockAddr -> Int -> IO (Maybe Socket)
 connect' addr port = do
@@ -720,15 +752,19 @@ xmlifyPresenceForPeer sock (Presence jid stat) = do
     addr <- getSocketName sock
     let n = name jid
         rsc = resource jid
-        jid_str = n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
-    return . L.unlines $
-      [ "<presence from='" <++> jid_str <++> "' " <++> typ stat <++> ">"
-      , "<show>" <++> shw stat <++> "</show>"
-      , "</presence>"
+        jidstr = toStrict . L.decodeUtf8 
+                  $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
+    return 
+      [ EventBeginElement "{jabber:server}presence" 
+            (("from",[ContentText jidstr]):typ stat)
+      , EventBeginElement "{jabber:server}show" []
+      , EventContent (ContentText . shw $ stat)
+      , EventEndElement "{jabber:server}show"
+      , EventEndElement "{jabber:server}presence"
       ]
  where
-    typ Offline = " type='unavailable'"
-    typ _       = ""
+    typ Offline = [("type",[ContentText "unavailable"])]
+    typ _       = []
     shw Available = "chat"
     shw Away      = "away"
     shw Offline   = "away" -- Is this right?