Repaired broken stanzaFromList, probes are sent.

1 files changed, 17 insertions, 10 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index b812e584..a30d15d0 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -15,6 +15,7 @@ import Network.Socket
     , SockAddr(..)
     )
 import System.Endian (fromBE32)
+import Data.List (nub)
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
@@ -244,35 +245,41 @@ getSolicited' = textAdapter ConfigFiles.getSolicited
 
 sendProbesAndSolicitations state k laddr chan = do
     -- get all buddies & solicited matching k for all users
-    runTraversableT $ do
+    xs <- runTraversableT $ do
         cbu <- lift $ atomically $ readTVar $ clientsByUser state
         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
+        addr <- liftMT $ nub `fmap` resolvePeer h
         liftT $ guard (PeerKey addr == k)
+        -- Note: Earlier I was tempted to do all the IO
+        -- within the TraversableT monad.  That apparently
+        -- is a bad idea.  Perhaps due to laziness and an
+        -- unforced list?  Instead, we will return a list
+        -- of (Bool,Text) for processing outside.
+        return (isbud,u)
+    -- XXX: The following O(n²) nub may be a little
+    --      too onerous.
+    forM_ (nub xs) $ \(isbud,u) -> do
         let make = if isbud then presenceProbe 
                             else presenceSolicitation
             toh = peerKeyToText k
-            jid = unsplitJID (u,toh,r)
+            jid = unsplitJID (u,toh,Nothing)
             me = addrToText laddr
-        stanza <- lift $ make me jid
+        stanza <- make me jid
         -- send probes for buddies, solicitations for solicited.
-        lift $ atomically $ writeTChan chan stanza
-    return ()
+        putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid)
+        atomically $ writeTChan chan stanza
+    -- reverse xs `seq` return ()
 
 newConn state k addr outchan = do
     atomically $ modifyTVar' (keyToChan state)
         $ Map.insert k Conn { connChan = outchan
                             , auxAddr  = addr }
-    {-
-    -- DISABLED FOR NOW
-    -- (probably is terminating a thread via exception)
     when (isPeerKey k)
         $ sendProbesAndSolicitations state k addr outchan
-    -}
 
 eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k