untested: inform clients about remote presences

1 files changed, 4 insertions, 0 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 7fc11124..b9719fa4 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -183,6 +183,7 @@ data XMPPServerParameters =
     , xmppTellClientNameOfPeer :: ConnectionKey -> IO Text
     , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
+    , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
     , xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     }
 
@@ -1168,6 +1169,7 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                         _ -> return ()
                     stanzaToConduit stanza =$= wrapStanzaConduit stanza
                         $$ awaitForever
+                            -- TODO: PresenceStatus stanzas should be pushed to appropriate slots
                             $ liftIO . atomically . Slotted.push slots Nothing
                     case stanzaType stanza of
                         Error err tag | tagName tag=="{jabber:client}message" -> do
@@ -1578,6 +1580,8 @@ monitor sv params xmpp = do
                     case stanzaType stanza of
                         PresenceRequestStatus {} -> do
                             xmppAnswerProbe xmpp k stanza replyto
+                        PresenceStatus {} -> do
+                            xmppInformPeerPresence xmpp k stanza
                         _ -> return ()
                 _ -> return ()
             let deliver replyto = do