untested: inform clients about remote presences

1 files changed, 31 insertions, 5 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 3899a258..8656c91f 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -221,16 +221,21 @@ rosterGetStuff what state k = forClient state k (return [])
     peers <- atomically $ readTVar (associatedPeers state)
     addrs <- return $ addrs `Map.difference` peers
     sv <- atomically $ takeTMVar $ server state
+    -- Grok peers to associate with from the roster:
     forM_ (Map.keys addrs) $ \addr -> do
         putStrLn $ "new addr: "++show addr
         addPeer sv addr
+    -- Update local set of associated peers
     atomically $ do
         writeTVar (associatedPeers state) (addrs `Map.union` peers)
         putTMVar (server state) sv
     return jids
 
 rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text]
-rosterGetBuddies = rosterGetStuff ConfigFiles.getBuddies
+rosterGetBuddies state k = do
+    buds <- rosterGetStuff ConfigFiles.getBuddies state k
+    return buds
+
 rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
@@ -413,23 +418,43 @@ informClientPresence state k stanza = do
         flip (maybe $ return ()) mb $ \cstate -> do
         writeTVar (clientStatus cstate) $ Just dup
 
+informPeerPresence state k stanza = do
+    -- Presence must indicate full JID with resource...
+    flip (maybe $ return ()) (stanzaFrom stanza) $ \from -> do
+    let (muser,h,mresource) = splitJID from
+    flip (maybe $ return ()) mresource       $ \resource -> do
+    flip (maybe $ return ()) muser           $ \user -> do
+    
+    clients <- atomically $ do
+        -- TODO: Store the stanza
+        -- For now, all clients:
+        -- (TODO: interested/authorized clients only.)
+        ktc <- readTVar (keyToChan state)
+        runTraversableT $ do
+        (k,client) <- liftMT $ fmap Map.toList $ readTVar (clients state)
+        con <- liftMaybe $ Map.lookup k ktc 
+        return (k,con,client)
+    forM_ clients $ \(k,con,client) -> do
+        from' <- do
+            let ClientKey laddr = k
+            (_,trip) <- rewriteJIDForClient laddr from
+            return trip
+        sendModifiedStanzaToClient stanza (connChan con)
+
 answerProbe state k stanza chan = do
     putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
     ktc <- atomically $ readTVar (keyToChan state)
     replies <- runTraversableT $ do
-        let liftMaybe = liftT . maybeToList
-            liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a
-            liftIOMaybe = liftMT . fmap maybeToList
         to <- liftMaybe $ stanzaTo stanza
         conn <- liftMaybe $ Map.lookup k ktc
         let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
                                    --  probes.  Is this correct? Check the spec.
+        liftIOMaybe $ guardPortStrippedAddress h (auxAddr conn)
         u <- liftMaybe mu
         cbu <- lift . atomically $ readTVar (clientsByUser state)
         lpres <- liftMaybe $ Map.lookup u cbu
         clientState <- liftT $ Map.elems (networkClients lpres)
         stanza <- liftIOMaybe $ atomically (readTVar (clientStatus clientState))
-        -- TODO: from address!!
         let jid = unsplitJID (Just $ clientUser clientState
                              , ch
                              ,Just $ clientResource clientState)
@@ -472,6 +497,7 @@ main = runResourceT $ do
         , xmppSubscribeToRoster = \k -> return ()
         , xmppDeliverMessage = deliverMessage state
         , xmppInformClientPresence = informClientPresence state
+        , xmppInformPeerPresence = informPeerPresence state
         , xmppAnswerProbe = answerProbe state
         }
     liftIO $ do