{-# 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 - -}