detect away/available status for ptys

1 files changed, 45 insertions, 20 deletions

diff --git a/consolation.hs b/consolation.hs
index bced2839..640b51c2 100644
--- a/consolation.hs
+++ b/consolation.hs
@@ -6,6 +6,7 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
 import Data.Monoid
+import Data.Char
 import System.INotify ( initINotify, EventVariety(Modify), addWatch )
 import Data.Word      ( Word8 )
 import Data.Text      ( Text )
@@ -43,14 +44,23 @@ onLogin cs start = \e -> do
         Traversable.mapM (flip writeTVar Nothing) dead
         writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead
         return newborn
+    let getActive = do
+            tty <- readTVar $ csActiveTTY cs
+            utmp <- readTVar $ csUtmp cs
+            flip (maybe $ return (tty,Nothing))
+                 (Map.lookup ("tty"<>tshow tty) utmp)
+                $ \tuvar -> do
+            tu <- readTVar tuvar
+            return (tty,tu)
+            
     forM_ (Map.elems newborn) $ 
-        forkIO . start (csActiveTTY cs)
+        forkIO . start getActive
     -- forM_ (Map.elems dead   ) $ putStrLn . ("gone: "++) . show
 
 onTTY cs vtnum = atomically $ writeTVar (csActiveTTY cs) vtnum
 
 retryWhen var pred = do
-    value <- readTVar var
+    value <- var
     if pred value then retry
                   else return value
 
@@ -71,38 +81,53 @@ ujid u = do
     h <- textHostName
     return $ utmpUser u <> "@" <> h <> "/" <> resource u
 
-newCon :: (Text -> IO ()) -> TVar Word8 -> TVar (Maybe UtmpRecord) -> IO ()
+newCon :: (Text -> IO ()) -> STM (Word8,Maybe UtmpRecord) -> TVar (Maybe UtmpRecord) -> IO ()
 newCon log activeTTY utmp = do
-    (tty,u) <- atomically $
-        liftM2 (,) (readTVar activeTTY)
+    ((tty,tu),u) <- atomically $
+        liftM2 (,) activeTTY
                    (readTVar utmp)
     flip (maybe $ return ()) u $ \u -> do
     jid <- ujid u
-    log $ status (resource u) tty <> " " <> jid <> "  pid=" <> tshow (utmpPid u)
-    loop tty (Just u)
+    log $ status (resource u) tty tu <> " " <> jid <> "  pid=" <> tshow (utmpPid u)
+            <> if istty (resource u)
+                then " host=" <> tshow (utmpHost u)
+                else ""
+    loop tty tu (Just u)
  where
-    bstatus r ttynum = r == "tty" <> tshow ttynum
-    status r ttynum =
-        if bstatus r ttynum
+    bstatus r ttynum mtu
+        =  r == ttystr
+        || match mtu
+        where ttystr = "tty" <> tshow ttynum
+              searchstr mtu = maybe ttystr utmpHost $ do
+                tu <- mtu
+                guard (not $ Text.null $ utmpHost tu)
+                return tu
+              match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r
+    status r ttynum tu =
+        if bstatus r ttynum tu
             then "Available"
             else "Away     "
 
-    loop tty u = do
+    istty r = fst3 == "tty" && Text.all isDigit rst
+     where
+        (fst3,rst) = Text.splitAt 3 r
+
+    loop tty tu u = do
         what <- atomically $ foldr1 orElse
-            [ do tty' <- retryWhen activeTTY
-                            (\tty' -> bstatus r tty == bstatus r tty')
-                 return $ ttyChanged tty'
-            , do u' <- retryWhen utmp (==u)
+            [ do (tty',tu') <- retryWhen activeTTY
+                            (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu)
+                 return $ ttyChanged tty' tu'
+            , do u' <- retryWhen (readTVar utmp) (==u)
                  return $ utmpChanged u'
             ]
         what
       where
         r = maybe "" resource u
 
-        ttyChanged tty' = do
+        ttyChanged tty' tu' = do
             jid <- maybe (return "") ujid u
-            log $ status r tty' <> " " <> jid
-            loop tty' u
+            log $ status r tty' tu' <> " " <> jid
+            loop tty' tu' u
 
         utmpChanged u' = maybe dead changed u'
          where
@@ -110,7 +135,7 @@ newCon log activeTTY utmp = do
                 jid0 <- maybe (return "") ujid u
                 jid <- ujid u'
                 log $ "changed: " <> jid0 <> " --> " <> jid
-                loop tty (Just u')
+                loop tty tu (Just u')
             dead = do
                 jid <- maybe (return "") ujid u
                 log $ "Offline   " <> jid
@@ -129,7 +154,7 @@ main = do
 
     -- get active tty
     mtty <- monitorTTY (onTTY cs)
-    atomically $ retryWhen (csActiveTTY cs) (==0)
+    atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0)
 
     -- read utmp
     onLogin cs (newCon $ logit outvar) Modify