Construct & send presence probes.

1 files changed, 24 insertions, 5 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 3c68da4a..eb1774d1 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -645,6 +645,25 @@ goodbyePeer =
     , EventEndDocument
     ]
 
+presenceProbe sock fromjid tojid = do
+    addr <- getSocketName sock
+    let jidstr jid = toStrict . L.decodeUtf8 
+                      $ name jid <$++> "@" 
+                        <?++> showPeer (RemotePeer addr) 
+                        <++?>  "/" <++$> resource jid
+        from = jidstr fromjid
+        to = toStrict . L.decodeUtf8
+              $ name tojid <$++> "@"
+                <?++> showPeer (peer tojid)
+    return 
+      [ EventBeginElement "{jabber:server}presence"
+            [("from",[ContentText from])
+            ,("to",[ContentText to])
+            ,("type",[ContentText "probe"])
+            ]
+      , EventEndElement "{jabber:server}presence"
+      ]
+
 toPeer sock cache chan = do
     let -- log     = liftIO . L.putStrLn . ("(>P) " <++>)
         send xs = yield xs >> prettyPrint ">P: " xs
@@ -653,9 +672,9 @@ toPeer sock cache chan = do
         r <- lift $ xmlifyPresenceForPeer sock (Presence jid st)
         send r
     forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
-        forM_ (Set.toList froms) $ \from ->
-            -- TODO: send probe
-            return ()
+        forM_ (Set.toList froms) $ \from -> do
+            r <- liftIO $ presenceProbe sock from to
+            send r
     fix $ \loop -> do
         event <- lift . atomically $ readTChan chan
         case event of
@@ -663,8 +682,8 @@ toPeer sock cache chan = do
             r <- lift $ xmlifyPresenceForPeer sock p
             send r
           PresenceProbe from to -> do
-            -- TODO: send probe
-            liftIO $ putStrLn ("Connection ready, PresenceProbe " ++ show (from,to) ++ " (NOT IMPLEMENTED)")
+            r <- liftIO $ presenceProbe sock from to
+            send r
         loop
     send goodbyePeer