notify remote peers of utmp presences

1 files changed, 32 insertions, 8 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