From e0e39465f0e3816a46d3ee3f3ba8a02d597d39e8 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Thu, 6 Mar 2014 22:47:16 -0500
Subject: Do not send cached presence until a resource has sent initial
 presence.

---
 Presence/XMPPServer.hs |  2 --
 xmppServer.hs          | 31 +++++++++++++++++++++++++++----
 2 files changed, 27 insertions(+), 6 deletions(-)

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 9661391e..4dda1f70 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -190,7 +190,6 @@ data XMPPServerParameters =
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
     , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
     , xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
-    , xmppSendCachedPresenceToClient :: ConnectionKey -> TChan Stanza -> IO ()
     }
 
 
@@ -1592,7 +1591,6 @@ monitor sv params xmpp = do
                                   (Just rsc) -- to
                                   requestVersion
                               >>= ioWriteChan replyto
-                            xmppSendCachedPresenceToClient xmpp k replyto
                         SessionRequest -> do
                             me <- xmppTellMyNameToClient xmpp
                             let reply = iq_session_reply (stanzaId stanza) me
diff --git a/xmppServer.hs b/xmppServer.hs
index 709137dc..30ce774d 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -31,6 +31,8 @@ import System.Posix.User (getUserEntryForID,userName)
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified ConfigFiles
 import Data.Maybe (maybeToList,listToMaybe,mapMaybe)
+import Data.Bits
+import Data.Int (Int8)
 
 import TraversableT
 import UTmp (ProcessID,users)
@@ -73,13 +75,24 @@ localJID user resource = do
     hostname <- textHostName
     return $ user <> "@" <> hostname <> "/" <> resource
 
+cf_available :: Int8
+cf_available = 0x1
+cf_interested :: Int8
+cf_interested = 0x2
+
 data ClientState = ClientState
     { clientResource :: Text
     , clientUser :: Text
     , clientPid :: Maybe ProcessID
     , clientStatus :: TVar (Maybe Stanza)
+    , clientFlags :: Int8
     }
 
+-- | True if the client has sent an initial presence
+clientIsAvailable c  = clientFlags c .&. cf_available /= 0
+
+-- | True if the client has requested a roster
+clientIsInterested c = clientFlags c .&. cf_interested /= 0
 
 data LocalPresence = LocalPresence
     { networkClients :: Map ConnectionKey ClientState
@@ -160,7 +173,8 @@ chooseResourceName state k addr desired = do
     let client = ClientState { clientResource = maybe "fallback" id mtty
                              , clientUser = user
                              , clientPid = pid
-                             , clientStatus = status }
+                             , clientStatus = status
+                             , clientFlags = 0 }
 
     atomically $ do
         modifyTVar' (clients state) $ Map.insert k client
@@ -454,6 +468,12 @@ informClientPresence state k stanza = do
         flip (maybe $ return ()) mb $ \cstate -> do
         writeTVar (clientStatus cstate) $ Just dup
     forClient state k (return ()) $ \client -> do
+    when (not $ clientIsAvailable client) $ do
+        atomically $ modifyTVar' (clients state)
+            $ Map.adjust  
+                (\c -> c { clientFlags = clientFlags c .|. cf_available })
+                k
+        sendCachedPresence state k
     jids <- configText ConfigFiles.getSubscribers (clientUser client)
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     addrs <- fmap Map.keys $ resolveAllPeers hosts 
@@ -551,7 +571,7 @@ answerProbe state k stanza chan = do
         pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline
         atomically $ writeTChan (connChan conn) pstanza
 
-sendCachedPresence state k chan = do
+sendCachedPresence state k = do
     -- TODO: send buddies in remotesByPeer
     forClient state k (return ()) $ \client -> do
     rbp <- atomically $ readTVar (remotesByPeer state)
@@ -569,8 +589,11 @@ sendCachedPresence state k chan = do
         forM_ js $ \jid -> do
         let from' = unsplitJID jid
         dup <- cloneStanza stanza
+        mcon <- atomically $ do ktc <- readTVar (keyToChan state)
+                                return $ Map.lookup k ktc
+        flip (maybe $ return ()) mcon $ \con -> do
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
-                                   chan -- (connChan con)
+                                   (connChan con)
 
     -- TODO: send local buddies in clientsByUser
     return ()
@@ -610,7 +633,7 @@ main = runResourceT $ do
         , xmppInformClientPresence = informClientPresence state
         , xmppInformPeerPresence = informPeerPresence state
         , xmppAnswerProbe = answerProbe state
-        , xmppSendCachedPresenceToClient = sendCachedPresence state
+        -- , xmppSendCachedPresenceToClient = sendCachedPresence state
         }
     liftIO $ do
     atomically $ putTMVar (server state) sv
-- 
cgit v1.2.3