1 files changed, 259 insertions, 0 deletions

diff --git a/dht/Presence/UTmp.hs b/dht/Presence/UTmp.hs
new file mode 100644
index 00000000..fcfe529a
--- /dev/null
+++ b/dht/Presence/UTmp.hs
@@ -0,0 +1,259 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
+module UTmp
+    ( users
+    , users2
+    , utmp_file
+    , UserName
+    , Tty
+    , ProcessID
+    , UtmpRecord(..)
+    , UT_Type(..)
+    ) where
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.BitSyntax
+import Data.Functor.Identity
+import Data.Maybe
+import Data.String
+import System.Posix.Process
+import System.Posix.Signals
+import System.Posix.Types
+import System.Posix.User
+import Control.Monad
+import Data.Word
+import Data.Int
+import Control.Monad.Error.Class
+import System.IO.Error
+import qualified Paths
+import Data.Text      ( Text )
+import Unsafe.Coerce  ( unsafeCoerce )
+import Network.Socket ( SockAddr(..) )
+import qualified Data.Text.Encoding as Text
+import SockAddr ()
+
+
+utmp_file :: IsString s => s
+utmp_file = fromString $ Paths.utmp -- "/var/run/utmp"
+
+utmp_bs :: IO C.ByteString
+utmp_bs = S.readFile utmp_file
+
+decode_utmp_bytestring ::
+    C.ByteString
+    -> (Word32,
+        Word32,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        Word16,
+        Word16,
+        Word32,
+        C.ByteString,
+        Word32,
+        Word32,
+        Word32,
+        Word32)
+decode_utmp_bytestring = 
+    runIdentity 
+    . $(bitSyn [ UnsignedLE 4 -- type
+               , UnsignedLE 4 -- pid
+               , Fixed 32 -- tty
+               , Fixed 4 -- inittab id
+               , Fixed 32 -- username
+               , Fixed 256 -- remote host
+               , UnsignedLE 2 -- termination status
+               , UnsignedLE 2 -- exit status (int)
+               , UnsignedLE 4 -- session id  (int)
+               , Fixed 8 -- time entry was made
+               , Unsigned 4 -- remote addr v6 addr[0]
+               , Unsigned 4 -- remote addr v6 addr[1]
+               , Unsigned 4 -- remote addr v6 addr[2]
+               , Unsigned 4 -- remote addr v6 addr[3]
+               , Skip 20 -- reserved
+               ])
+
+utmp_size :: Int
+utmp_size = 384 -- 768
+
+
+utmp_records :: C.ByteString -> [C.ByteString]
+utmp_records bs | S.length bs >= utmp_size 
+    =  u:utmp_records us
+ where
+    (u,us) = S.splitAt utmp_size bs
+
+utmp_records bs = [bs]
+
+utmp ::
+    IO
+      [(Word32,
+        Word32,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        Word16,
+        Word16,
+        Word32,
+        C.ByteString,
+        Word32,
+        Word32,
+        Word32,
+        Word32)]
+utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
+
+toStr :: C.ByteString -> [Char]
+toStr = takeWhile (/='\0') . C.unpack
+
+interp_utmp_record ::
+    forall t t1 t2 t3 t4 t5 t6 t7 t8 a.
+    Integral a =>
+    (a,
+     Word32,
+     C.ByteString,
+     t,
+     C.ByteString,
+     C.ByteString,
+     t1,
+     t2,
+     t3,
+     t4,
+     t5,
+     t6,
+     t7,
+     t8)
+    -> (UT_Type, [Char], [Char], CPid, [Char])
+interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time
+                   ,addr0,addr1,addr2,addr3) =
+    ( (toEnum . fromIntegral) typ :: UT_Type
+    , toStr user, toStr tty, processId pid, toStr hostv4 )
+ where
+    processId = CPid . coerceToSigned
+
+coerceToSigned :: Word32 -> Int32
+coerceToSigned = unsafeCoerce
+
+
+data UT_Type
+ = EMPTY           -- No valid user accounting information.  */
+
+ | RUN_LVL         -- The system's runlevel.  */
+ | BOOT_TIME       -- Time of system boot.  */
+ | NEW_TIME        -- Time after system clock changed.  */
+ | OLD_TIME        -- Time when system clock changed.  */
+
+ | INIT_PROCESS    -- Process spawned by the init process.  */
+ | LOGIN_PROCESS   -- Session leader of a logged in user.  */
+ | USER_PROCESS    -- Normal process.  */
+ | DEAD_PROCESS    -- Terminated process.  */
+
+ | ACCOUNTING      
+
+ deriving (Enum,Show,Eq,Ord,Read)
+
+processAlive :: ProcessID -> IO Bool
+processAlive pid = do
+    catchError (do { signalProcess nullSignal pid ; return True })
+      $ \e -> do { return (not ( isDoesNotExistError e)); }
+
+type UserName = L.ByteString
+type Tty      = L.ByteString
+
+users :: IO [(UserName, Tty, ProcessID)]
+users = utmp_users `catchIOError` \_ -> do
+            -- If we can't read utmp file, then return a list with only the current
+            -- user.
+            uname <- getLoginName
+            pid <- getProcessID -- TODO: XXX: Does this make sense as a fallback?
+            return [(L.pack uname,L.empty,pid)]
+ where
+  utmp_users = fmap (map only3) $ do
+    us <- utmp
+    let us' = map interp_utmp_record us
+        us'' = mapMaybe user_proc us'
+        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 :: forall t t1 t2 t3. (t1, t2, t3, t) -> (t1, t2, t3)
+only3 (a,b,c,_) = (a,b,c)
+
+data UtmpRecord = UtmpRecord
+  { utmpType :: UT_Type
+  , utmpUser :: Text
+  , utmpTty :: Text
+  , utmpPid :: CPid
+  , utmpHost :: Text
+  , utmpSession :: Int32
+  , utmpRemoteAddr :: Maybe SockAddr
+  }
+ deriving ( Show, Eq, Ord )
+
+toText :: C.ByteString -> Text
+toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs
+
+interp_utmp_record2 ::
+    forall t t1 t2 t3 a.
+    Integral a =>
+    (a,
+     Word32,
+     C.ByteString,
+     t,
+     C.ByteString,
+     C.ByteString,
+     t1,
+     t2,
+     Word32,
+     t3,
+     Word32,
+     Word32,
+     Word32,
+     Word32)
+    -> UtmpRecord
+interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4
+                    ,term,exit,session,time,addr0,addr1,addr2,addr3) =
+    UtmpRecord
+        { utmpType = toEnum (fromIntegral typ) :: UT_Type
+        , utmpUser = toText user
+        , utmpTty  = toText tty
+        , utmpPid  = processId pid
+        , utmpHost = toText hostv4
+        , utmpSession = coerceToSigned session
+        , utmpRemoteAddr =
+            if all (==0) [addr1,addr2,addr3]
+             then do guard (addr0/=0)
+                     Just $ SockAddrInet6 0 0 (0,0,0xFFFF,addr0) 0
+             else Just $ SockAddrInet6 0 0 (addr0,addr1,addr2,addr3) 0
+        }
+ where
+    processId = CPid . coerceToSigned
+
+users2 :: IO [UtmpRecord]
+users2 = do
+    us <- utmp
+    let us' = map interp_utmp_record2 us
+    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
+ - 
+ -}