untested: inform clients about remote presences

3 files changed, 41 insertions, 5 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
diff --git a/TraversableT.hs b/TraversableT.hs
index cd04731c..98a97bf6 100644
--- a/TraversableT.hs
+++ b/TraversableT.hs
@@ -5,6 +5,7 @@ import Control.Monad (join,MonadPlus(..))
 import Control.Monad.Trans.Class
 import Control.Applicative
 import Data.Foldable (Foldable(foldMap))
+import Data.Maybe (maybeToList)
 
 -- | 
 --
@@ -75,4 +76,9 @@ liftCatch :: (m (t a) -> (e -> m (t a)) -> m (t a)) ->
 liftCatch catchError m h = TraversableT $ runTraversableT m
     `catchError` \e -> runTraversableT (h e)
 
+liftMaybe :: Monad m => Maybe a -> TraversableT [] m a
+liftMaybe = liftT . maybeToList
+
+liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a
+liftIOMaybe = liftMT . fmap maybeToList
 
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