consolation demo program

4 files changed, 126 insertions, 6 deletions

diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
index e5832b47..6f7735dd 100644
--- a/Presence/LocalPeerCred.hs
+++ b/Presence/LocalPeerCred.hs
@@ -162,6 +162,7 @@ scanProc uid inode = do
                               tty <- readSymbolicLink $ "/proc/"++pid++"/fd/0"
                               return (Just (pid,tty))
                             else loop fds
+                -- requires root (or same user as for pid)...
                 fds <- getDirectoryContents ("/proc/"++pid++"/fd") `catchIO_` return []
                 mb <- loop fds
                 maybe (searchPids pids) (return . Just) mb
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
index a3adaeee..86a19751 100644
--- a/Presence/UTmp.hs
+++ b/Presence/UTmp.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE TemplateHaskell #-}
 module UTmp 
     ( users
+    , users2
     , utmp_file
     , UserName
     , Tty
     , ProcessID
+    , UtmpRecord(..)
     ) where
 
 import qualified Data.ByteString as S
@@ -22,6 +24,8 @@ import Data.Int
 import Control.Monad.Error.Class
 import System.IO.Error
 import qualified Paths
+import Data.Text ( Text )
+import qualified Data.Text.Encoding as Text
 
 
 utmp_file = Paths.utmp -- "/var/run/utmp"
@@ -56,11 +60,12 @@ utmp_records bs = [bs]
 
 utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
 
+toStr = takeWhile (/='\0') . C.unpack
 
 interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time,hostv6) =
-    (toStr user, toStr tty, processId pid, (toEnum . fromIntegral) typ :: UT_Type)
+    ( (toEnum . fromIntegral) typ :: UT_Type
+    , toStr user, toStr tty, processId pid, toStr hostv4 )
  where
-    toStr = takeWhile (/='\0') . C.unpack
     processId = CPid . coerce
     coerce :: Word32 -> Int32
     coerce = unsafeCoerce
@@ -91,12 +96,65 @@ type UserName = L.ByteString
 type Tty      = L.ByteString
 
 users :: IO [(UserName, Tty, ProcessID)]
-users = do
+users = fmap (map only3) $ do
     us <- utmp
     let us' = map interp_utmp_record us
         us'' = mapMaybe user_proc us'
-        user_proc (u,tty,pid,USER_PROCESS) = Just (L.pack u,L.pack tty,pid)
-        user_proc _                        = Nothing
-        onThrd f (_,_,pid) = f pid
+        user_proc (USER_PROCESS, u,tty,pid, hostv4)
+                    = Just (L.pack u,L.pack tty,pid,hostv4)
+        user_proc _ = Nothing
+        onThrd f (_,_,pid,_) = f pid
     us3 <- filterM (onThrd processAlive) us''
     return us3
+
+only3 (a,b,c,_) = (a,b,c)
+
+data UtmpRecord = UtmpRecord
+  { utmpUser :: Text
+  , utmpTty :: Text
+  , utmpPid :: CPid
+  , utmpHost :: Text
+  }
+ deriving ( Show, Read, Eq, Ord )
+
+toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs
+
+interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4,term,exit,session,time,hostv6) =
+    ( (toEnum . fromIntegral) typ :: UT_Type
+    , UtmpRecord
+        { utmpUser = toText user
+        , utmpTty  = toText tty
+        , utmpPid  = processId pid
+        , utmpHost = toText hostv4 }
+    )
+ where
+    processId = CPid . coerce
+    coerce :: Word32 -> Int32
+    coerce = unsafeCoerce
+
+-- users2 :: IO [(UserName, Tty, ProcessID)]
+users2 = do
+    us <- utmp
+    let us' = map interp_utmp_record2 us
+        us'' = mapMaybe user_proc us'
+        user_proc (USER_PROCESS, rec)
+                    = Just rec
+        user_proc _ = Nothing
+    us3 <- filterM (processAlive . utmpPid) us''
+    return us3
+
+{- 
+ - This is how the w command reports idle time:
+/* stat the device file to get an idle time */
+static time_t idletime(const char *restrict const tty)
+{
+        struct stat sbuf;
+        if (stat(tty, &sbuf) != 0)
+                return 0;
+        return time(NULL) - sbuf.st_atime;
+}
+ - THis might be useful fo rimplementing
+ - xep-0012 Last Activity
+ - iq get {jabber:iq:last}query
+ - 
+ -}
diff --git a/WaitForSignal.hs b/WaitForSignal.hs
new file mode 100644
index 00000000..6252eaa6
--- /dev/null
+++ b/WaitForSignal.hs
@@ -0,0 +1,10 @@
+module WaitForSignal where
+
+import Control.Concurrent.STM
+import System.Posix.Signals
+
+waitForTermSignal = do
+    quitVar <- newEmptyTMVarIO
+    installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
+    installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
+    atomically $ takeTMVar quitVar
diff --git a/consolation.hs b/consolation.hs
new file mode 100644
index 00000000..d3c0ef28
--- /dev/null
+++ b/consolation.hs
@@ -0,0 +1,51 @@
+
+import Control.Monad
+import Control.Applicative
+import Control.Concurrent.STM
+import System.INotify ( initINotify, EventVariety(Modify), addWatch )
+import Data.Word      ( Word8 )
+import Data.Text      ( Text )
+import Data.Map       ( Map )
+import Data.List      ( foldl' )
+import qualified Data.Map as Map
+
+import WaitForSignal  ( waitForTermSignal )
+import UTmp           ( users2, utmp_file, UtmpRecord(..) )
+import FGConsole      ( monitorTTY )
+
+data ConsoleState = ConsoleState
+    { csActiveTTY :: TVar Word8
+    , csUtmp :: TVar (Map Text UtmpRecord)
+    }
+
+newConsoleState = atomically $
+    ConsoleState <$> newTVar 0 <*> newTVar Map.empty
+
+onLogin cs e = do
+    us <- UTmp.users2
+    let m = foldl' (\m x -> Map.insert (utmpTty x) x m) Map.empty us
+    old <- atomically $ swapTVar (csUtmp cs) m
+    let newborn = m Map.\\ old
+        dead = old Map.\\ m
+    putStrLn $ "--------"
+    forM_ (Map.elems newborn) $ putStrLn . ("new:  "++) . show
+    forM_ (Map.elems dead   ) $ putStrLn . ("gone: "++) . show
+
+onTTY cs vtnum = do
+    prev <- atomically $ swapTVar (csActiveTTY cs) vtnum
+    putStrLn $ "tty: " ++ show vtnum
+
+main = do
+    cs <- newConsoleState
+    inotify <- initINotify
+    wd <- addWatch
+            inotify
+            [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move]
+            utmp_file
+            (onLogin cs)
+
+    mtty <- monitorTTY (onTTY cs)
+
+    waitForTermSignal
+
+    putStrLn "goodbye."