notify remote peers of utmp presences

3 files changed, 58 insertions, 52 deletions

diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index 5222258e..3b02dbbc 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -28,12 +28,14 @@ import qualified Network.BSD as BSD
 import UTmp           ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
 import FGConsole      ( monitorTTY )
 import XMPPServer     ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
-                      , LangSpecificMessage(..), msgLangMap )
+                      , LangSpecificMessage(..), msgLangMap, cloneStanza )
+import ClientState
 
 data ConsoleWriter = ConsoleWriter
-    { cwPresenceChan :: TChan Stanza
+    { cwPresenceChan :: TChan (ClientState,Stanza)
     , csActiveTTY :: TVar Word8
     , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
+    , cwClients :: TVar (Map Text ClientState)
     }
 
 tshow x = Text.pack . show $ x
@@ -87,9 +89,11 @@ newConsoleWriter = do
     cs <- atomically $ do
         ttyvar <- newTVar 0
         utmpvar <- newTVar Map.empty
+        clients <- newTVar Map.empty
         return $ ConsoleWriter { cwPresenceChan = chan
                                , csActiveTTY = ttyvar
                                , csUtmp = utmpvar
+                               , cwClients = clients
                                }
     outvar <- atomically $ newTMVar ()
     let logit outvar s = do
@@ -216,7 +220,22 @@ newCon log cw activeTTY utmp = do
                  else "")
             <> " session=" <> tshow (utmpSession u)
             <> " addr=" <> tshow (utmpRemoteAddr u)
-    loop tty tu (Just u)
+    let r = resource u
+    stanza <- makePresenceStanza
+                            "jabber:client"
+                            (Just jid)
+                            (jstatus r tty tu)
+    statusv <- atomically $ newTVar (Just stanza)
+    flgs <- atomically $ newTVar 0
+    let client = ClientState { clientResource = r
+                             , clientUser = utmpUser u
+                             , clientPid = Nothing
+                             , clientStatus = statusv
+                             , clientFlags = flgs }
+    atomically $ do
+        modifyTVar (cwClients cw) $ Map.insert r client
+        writeTChan (cwPresenceChan cw) (client,stanza)
+    loop client tty tu (Just u)
  where
     bstatus r ttynum mtu
         =  r == ttystr
@@ -237,7 +256,7 @@ newCon log cw activeTTY utmp = do
      where
         (fst3,rst) = Text.splitAt 3 r
 
-    loop tty tu u = do
+    loop client tty tu u = do
         what <- atomically $ foldr1 orElse
             [ do (tty',tu') <- retryWhen activeTTY
                             (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu)
@@ -255,9 +274,12 @@ newCon log cw activeTTY utmp = do
                             "jabber:client"
                             (Just jid)
                             (jstatus r tty' tu')
-            atomically $ writeTChan (cwPresenceChan cw) stanza
+            dup <- cloneStanza stanza
+            atomically $ do
+                writeTVar (clientStatus client) $ Just dup
+                writeTChan (cwPresenceChan cw) (client,stanza)
             log $ status r tty' tu' <> " " <> jid
-            loop tty' tu' u
+            loop client tty' tu' u
 
         utmpChanged u' = maybe dead changed u'
          where
@@ -265,10 +287,12 @@ newCon log cw activeTTY utmp = do
                 jid0 <- maybe (return "") ujid u
                 jid <- ujid u'
                 log $ "changed: " <> jid0 <> " --> " <> jid
-                loop tty tu (Just u')
+                loop client tty tu (Just u')
             dead = do
                 jid <- maybe (return "") ujid u
                 stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
-                atomically $ writeTChan (cwPresenceChan cw) stanza
+                atomically $ do
+                    modifyTVar (cwClients cw) $ Map.delete (clientResource client)
+                    writeTChan (cwPresenceChan cw) (client,stanza)
                 log $ "Offline   " <> jid
 
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
index 99d51205..2cfbdf38 100644
--- a/Presence/UTmp.hs
+++ b/Presence/UTmp.hs
@@ -28,6 +28,7 @@ import Data.Text      ( Text )
 import Unsafe.Coerce  ( unsafeCoerce )
 import Network.Socket ( SockAddr(..) )
 import qualified Data.Text.Encoding as Text
+import SockAddr ()
 
 
 utmp_file = Paths.utmp -- "/var/run/utmp"
diff --git a/xmppServer.hs b/xmppServer.hs
index d5ad7c6a..1ab36cd6 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -37,6 +37,7 @@ import LocalPeerCred
 import XMPPServer
 import PeerResolve
 import ConsoleWriter
+import ClientState
 
 type UserName = Text
 type ResourceName = Text
@@ -74,28 +75,6 @@ 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 :: TVar Int8
-    }
-
--- | True if the client has sent an initial presence
-clientIsAvailable c  = do
-    flgs <- readTVar (clientFlags c)
-    return $ flgs .&. cf_available /= 0
-
--- | True if the client has requested a roster
-clientIsInterested c = do
-    flgs <- readTVar (clientFlags c)
-    return $ flgs .&. cf_interested /= 0
 
 data LocalPresence = LocalPresence
     { networkClients :: Map ConnectionKey ClientState
@@ -130,7 +109,7 @@ pcIsEmpty pc = Map.null (networkClients pc)
 data PresenceState = PresenceState
     { clients :: TVar (Map ConnectionKey ClientState)
     , clientsByUser :: TVar (Map Text LocalPresence)
-    , remotesByPeer :: TVar (Map (Maybe ConnectionKey)
+    , remotesByPeer :: TVar (Map ConnectionKey
                                  (Map UserName
                                       RemotePresence))
     , associatedPeers :: TVar (Map SockAddr ())
@@ -326,13 +305,13 @@ eofConn state k = do
             jids <- atomically $ do
                 rbp <- readTVar (remotesByPeer state)
                 return $ do
-                    umap <- maybeToList $ Map.lookup (Just k) rbp
+                    umap <- maybeToList $ Map.lookup k rbp
                     (u,rp) <- Map.toList umap
                     r <- Map.keys (resources rp)
                     return $ unsplitJID (Just u, h, Just r)
             forM_ jids $ \jid -> do
             stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
-            informPeerPresence state (Just k) stanza
+            informPeerPresence state k stanza
 
 {-
 rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr))
@@ -480,10 +459,13 @@ deliverMessage state fail msg =
 
 
 setClientFlag state k flag = 
-        atomically $ do
-            cmap <- readTVar (clients state)
-            flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do
-            modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
+    atomically $ do
+        cmap <- readTVar (clients state)
+        flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do
+        setClientFlag0 client flag
+
+setClientFlag0 client flag = 
+    modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
 
 informSentRoster state k = do
     setClientFlag state k cf_interested
@@ -503,16 +485,16 @@ clientJID con client = unsplitJID ( Just $ clientUser client
 -- Note that a full JID from address will be added to the
 -- stanza if it is not present.
 informClientPresence state k stanza = do
-    dup <- cloneStanza stanza
-    atomically $ do
-        mb <- fmap (Map.lookup k) $ readTVar (clients state)
-        flip (maybe $ return ()) mb $ \cstate -> do
-        writeTVar (clientStatus cstate) $ Just dup
     forClient state k (return ()) $ \client -> do
+    informClientPresence0 state (Just k) client stanza
+
+informClientPresence0 state mbk client stanza = do
+    dup <- cloneStanza stanza
+    atomically $ writeTVar (clientStatus client) $ Just dup
     is_avail <- atomically $ clientIsAvailable client
     when (not is_avail) $ do
-        setClientFlag state k cf_available
-        sendCachedPresence state k
+        atomically $ setClientFlag0 client cf_available
+        maybe (return ()) (sendCachedPresence state) mbk
     addrs <- subscribedPeers (clientUser client)
     ktc <- atomically $ readTVar (keyToChan state)
     let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs
@@ -579,7 +561,7 @@ informPeerPresence state k stanza = do
         is_avail <- atomically $ clientIsAvailable client
         when is_avail $ do
         putStrLn $ "reversing for client: " ++ show from
-        froms <- flip (maybe $ return [from]) k . const $ do
+        froms <- do -- flip (maybe $ return [from]) k . const $ do
             let ClientKey laddr = ck
             (_,trip) <- multiplyJIDForClient laddr from
             return (map unsplitJID trip)
@@ -649,16 +631,15 @@ sendCachedPresence state k = do
     jids <- configText ConfigFiles.getBuddies (clientUser client)
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     addrs <- resolveAllPeers hosts 
-    let onlines = rbp `Map.intersection` (Map.insert Nothing () -- send console presences
-                                            $ Map.mapKeys (Just . PeerKey) addrs)
+    let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs
         ClientKey laddr = k
     mcon <- atomically $ do ktc <- readTVar (keyToChan state)
                             return $ Map.lookup k ktc
     flip (maybe $ return ()) mcon $ \con -> do
-    me <- textHostName
+    -- me <- textHostName
     forM_ (Map.toList onlines) $ \(pk, umap) -> do
         forM_ (Map.toList umap) $ \(user,rp) -> do
-        let h = maybe me peerKeyToText pk
+        let h = peerKeyToText pk
         forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
         let jid = unsplitJID (Just user,h,Just resource)
         (mine,js) <- multiplyJIDForClient laddr jid
@@ -1002,7 +983,7 @@ main = runResourceT $ do
         , xmppSubscribeToRoster = informSentRoster state
         , xmppDeliverMessage = deliverMessage state
         , xmppInformClientPresence = informClientPresence state
-        , xmppInformPeerPresence = \k -> informPeerPresence state (Just k)
+        , xmppInformPeerPresence = informPeerPresence state
         , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan
         , xmppClientSubscriptionRequest = clientSubscriptionRequest state
         , xmppPeerSubscriptionRequest = peerSubscriptionRequest state
@@ -1020,8 +1001,8 @@ main = runResourceT $ do
         console <- atomically $ dupTChan (cwPresenceChan $ consoleWriter state)
         fix $ \loop -> do
         what <- atomically
-            $ orElse (do stanza <- readTChan console
-                         return $ do informPeerPresence state Nothing stanza
+            $ orElse (do (client,stanza) <- readTChan console
+                         return $ do informClientPresence0 state Nothing client stanza
                                      loop)
                      (do readTMVar quitVar
                          return $ return ())