2 files changed, 35 insertions, 21 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index f6df1525..0103ba46 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -456,22 +456,29 @@ stanzaFromList stype reply = do
         mid   = stanzaTag >>= lookupAttrib "id" . tagAttrs
         mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
         mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
+        {-
         isInternal (InternalEnableHack {}) = True
         isInternal (InternalCacheId {}) = True
         isInternal _ = False
-    atomically $ do
-        donevar <- newEmptyTMVar
+        -}
+    (donevar,replyChan,replyClsrs) <- atomically $ do
+        donevar <- newEmptyTMVar -- TMVar ()
         replyChan <- newLockedChan
         replyClsrs <- newTVar (Just [])
-        return Stanza { stanzaType = stype
-                      , stanzaId = mid
-                      , stanzaTo = mto      -- as-is from reply list
-                      , stanzaFrom = mfrom  -- as-is from reply list
-                      , stanzaChan = replyChan
-                      , stanzaClosers = replyClsrs
-                      , stanzaInterrupt = donevar
-                      , stanzaOrigin = LocalPeer
-                      }
+        return (donevar,replyChan, replyClsrs)
+    forkIO $ do
+        forM_ reply $ atomically . writeLChan replyChan
+        atomically $ do putTMVar donevar ()
+                        writeTVar replyClsrs Nothing
+    return Stanza { stanzaType = stype
+                  , stanzaId = mid
+                  , stanzaTo = mto      -- as-is from reply list
+                  , stanzaFrom = mfrom  -- as-is from reply list
+                  , stanzaChan = replyChan
+                  , stanzaClosers = replyClsrs
+                  , stanzaInterrupt = donevar
+                  , stanzaOrigin = LocalPeer
+                  }
 
 grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
 grokStanzaIQGet stanza = do
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