{-# 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 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 :: String
utmp_file = 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
 - 
 -}