send probes and solicitations

2 files changed, 35 insertions, 14 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 5dda4f4d..b895597f 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -19,6 +19,8 @@ module XMPPServer
     , addrToText
     , sendModifiedStanzaToPeer
     , sendModifiedStanzaToClient
+    , presenceProbe
+    , presenceSolicitation
     ) where
 
 import Debug.Trace
@@ -1025,6 +1027,19 @@ simulateChatError err mfrom =
     ]
 
 
+presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe"
+
+presenceProbe = presenceStanza PresenceRequestStatus "probe"
+
+presenceStanza stanza_type type_attr me jid =
+    stanzaFromList stanza_type
+        [ EventBeginElement "{jabber:server}presence"
+                [ attr "to" jid
+                , attr "from" me
+                , attr "type" type_attr
+                ]
+        , EventEndElement "{jabber:server}presence" ]
+
 forkConnection :: Server ConnectionKey SockAddr
                 -> XMPPServerParameters
                 -> ConnectionKey
diff --git a/xmppServer.hs b/xmppServer.hs
index 0f2b7c89..d450988c 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -4,6 +4,7 @@ import System.Posix.Signals
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMVar
 import Control.Monad.Trans.Resource (runResourceT)
+import Control.Monad.Trans
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Network.Socket
     ( addrAddress
@@ -240,21 +241,26 @@ getBuddies' = textAdapter ConfigFiles.getBuddies
 getSolicited' :: Text -> IO [Text]
 getSolicited' = textAdapter ConfigFiles.getSolicited
 
-sendProbesAndSolicitations state k chan = do
+sendProbesAndSolicitations state k laddr chan = do
     cbu <- atomically $ readTVar $ clientsByUser state
     -- get all buddies & solicited matching k for all users
-    us <- runTraversableT $ do
-            user <- liftT $ Map.keys cbu
-            (isbud,getter) <- liftT [(True ,getBuddies'  )
-                                    ,(False,getSolicited')]
-            bud  <- liftMT $ getter user
-            let (u,h,r) = splitJID bud
-            addr <- liftMT $ resolvePeer h
-            liftT $ guard (PeerKey addr == k)
-            return (isbud,u)
-    
-    let _ = us :: [(Bool,Maybe UserName)]
-    -- send probes for buddies, solicitations for solicited.
+    runTraversableT $ do
+        user <- liftT $ Map.keys cbu
+        (isbud,getter) <- liftT [(True ,getBuddies'  )
+                                ,(False,getSolicited')]
+        bud  <- liftMT $ getter user
+        let (u,h,r) = splitJID bud
+        addr <- liftMT $ resolvePeer h
+        liftT $ guard (PeerKey addr == k)
+        -- return (isbud,u)
+        let make = if isbud then presenceProbe 
+                            else presenceSolicitation
+            toh = peerKeyToText k
+            jid = unsplitJID (u,toh,r)
+            me = addrToText laddr
+        stanza <- lift $ make me jid
+        -- send probes for buddies, solicitations for solicited.
+        lift $ atomically $ writeTChan chan stanza
     return ()
 
 newConn state k addr outchan = do
@@ -262,7 +268,7 @@ newConn state k addr outchan = do
         $ Map.insert k Conn { connChan = outchan
                             , auxAddr  = addr }
     when (isPeerKey k)
-        $ sendProbesAndSolicitations state k outchan
+        $ sendProbesAndSolicitations state k addr outchan
 
 eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k