From f41fa27ea09557b103a4dcba07228d334cb4335d Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Thu, 13 Mar 2014 03:04:25 -0400
Subject: output jids in consolation demo

---
 consolation.hs | 68 +++++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 53 insertions(+), 15 deletions(-)

diff --git a/consolation.hs b/consolation.hs
index a248098a..bced2839 100644
--- a/consolation.hs
+++ b/consolation.hs
@@ -14,6 +14,8 @@ import Data.List      ( foldl' )
 import qualified Data.Map as Map
 import qualified Data.Traversable as Traversable
 import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Network.BSD as BSD
 
 import WaitForSignal  ( waitForTermSignal )
 import UTmp           ( users2, utmp_file, UtmpRecord(..) )
@@ -52,20 +54,38 @@ retryWhen var pred = do
     if pred value then retry
                   else return value
 
-newCon activeTTY utmp = do
+tshow x = Text.pack . show $ x
+
+resource :: UtmpRecord -> Text
+resource u =
+    case utmpTty u of
+        s | Text.take 3 s == "tty" -> s
+        s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u
+        s -> escapeR s <> ":" <> utmpHost u
+ where
+    escapeR s = s
+
+textHostName = fmap Text.pack BSD.getHostName
+
+ujid u = do
+    h <- textHostName
+    return $ utmpUser u <> "@" <> h <> "/" <> resource u
+
+newCon :: (Text -> IO ()) -> TVar Word8 -> TVar (Maybe UtmpRecord) -> IO ()
+newCon log activeTTY utmp = do
     (tty,u) <- atomically $
         liftM2 (,) (readTVar activeTTY)
                    (readTVar utmp)
-    putStrLn $ resource u ++ ": " ++ status (resource u) tty ++ " " ++ show u
-    loop tty u
+    flip (maybe $ return ()) u $ \u -> do
+    jid <- ujid u
+    log $ status (resource u) tty <> " " <> jid <> "  pid=" <> tshow (utmpPid u)
+    loop tty (Just u)
  where
-    bstatus r ttynum = r == "tty" ++ show ttynum
+    bstatus r ttynum = r == "tty" <> tshow ttynum
     status r ttynum =
         if bstatus r ttynum
             then "Available"
-            else "Away"
-
-    resource u = maybe "" (Text.unpack . utmpTty) u
+            else "Away     "
 
     loop tty u = do
         what <- atomically $ foldr1 orElse
@@ -77,31 +97,49 @@ newCon activeTTY utmp = do
             ]
         what
       where
-        r = resource u
+        r = maybe "" resource u
 
         ttyChanged tty' = do
-            putStrLn $ r ++ ": " ++ status r tty'
+            jid <- maybe (return "") ujid u
+            log $ status r tty' <> " " <> jid
             loop tty' u
 
         utmpChanged u' = maybe dead changed u'
          where
             changed u' = do
-                putStrLn $ r ++ " changed: " ++ show u'
+                jid0 <- maybe (return "") ujid u
+                jid <- ujid u'
+                log $ "changed: " <> jid0 <> " --> " <> jid
                 loop tty (Just u')
             dead = do
-                putStrLn $ r ++ ": Offline"
+                jid <- maybe (return "") ujid u
+                log $ "Offline   " <> jid
+
+logit outvar s = do
+    atomically $ takeTMVar outvar
+    Text.putStrLn s
+    atomically $ putTMVar outvar ()
+
 
 main = do
+    outvar <- atomically $ newTMVar ()
+
     cs <- newConsoleState
     inotify <- initINotify
-    onLogin cs newCon Modify -- initialize utmp records
+
+    -- get active tty
+    mtty <- monitorTTY (onTTY cs)
+    atomically $ retryWhen (csActiveTTY cs) (==0)
+
+    -- read utmp
+    onLogin cs (newCon $ logit outvar) Modify
+
+    -- monitor utmp
     wd <- addWatch
             inotify
             [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move]
             utmp_file
-            (onLogin cs newCon) -- update utmp records
-
-    mtty <- monitorTTY (onTTY cs)
+            (onLogin cs (newCon $ logit outvar))
 
     waitForTermSignal
 
-- 
cgit v1.2.3