Switched UTmp.users to return ByteStrings instead of Strings.

2 files changed, 33 insertions, 14 deletions

diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
index c2549a88..481612e3 100644
--- a/Presence/UTmp.hs
+++ b/Presence/UTmp.hs
@@ -1,9 +1,9 @@
-
 {-# LANGUAGE TemplateHaskell #-}
 module UTmp (users, utmp_file) 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
@@ -80,11 +80,15 @@ 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 = do
     us <- utmp
     let us' = map interp_utmp_record us
         us'' = mapMaybe user_proc us'
-        user_proc (u,tty,pid,USER_PROCESS) = Just (u,tty,pid)
+        user_proc (u,tty,pid,USER_PROCESS) = Just (L.pack u,L.pack tty,pid)
         user_proc _                        = Nothing
         onThrd f (_,_,pid) = f pid
     us3 <- filterM (onThrd processAlive) us''
diff --git a/Presence/main.hs b/Presence/main.hs
index d679fdba..f0bc39f5 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
+module Main where
 
 import System.Directory
 import Control.Monad
@@ -11,7 +12,15 @@ import Data.Maybe
 
 import System.INotify
 #ifndef NOUTMP
-import UTmp
+import UTmp 
+-- Breaks profiling build with error:
+--     Dynamic linking required, but this is a non-standard build (eg. prof).
+--         You need to build the program twice: once the normal way, and then
+--             in the desired way using -osuf to set the object file suffix.
+--
+-- TODO: Figure out wtf ghc is trying to tell me.
+--       In the mean time, use -DNOTMP to build for profiling.
+-- 
 #endif
 import FGConsole
 import XMPPServer
@@ -22,25 +31,28 @@ import LocalPeerCred
 import ByteStringOperators
 import qualified Data.ByteString.Lazy.Char8 as L
 import System.Posix.User
+import qualified Data.Set as Set
+import Data.Set (Set)
 
 
-jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc
+jid user host rsrc = user <++> "@" <++> host <++> "/" <++> rsrc
 
-toJabberId :: String -> (String,String,t) -> Maybe String
 toJabberId host (user,tty,_) = 
-    if take 3 tty == "tty"
+    if L.take 3 tty == "tty"
       then Just (jid user host tty)
       else Nothing
 
-#ifndef NOUTMP
-utmp_event e = do
+track_login :: IORef (Set L.ByteString) -> t -> IO ()
+track_login tracked e = do
     -- print e
     putStrLn "---"
+#ifndef NOUTMP
     us <- users
-    let ids = mapMaybe (toJabberId "localhost") us
-        ids :: [String]
-    forM_ ids putStrLn
+#else
+    let us = []
 #endif
+    let ids = mapMaybe (toJabberId "localhost") us
+    forM_ ids L.putStrLn
 
 data UnixSession = UnixSession {
     unix_uid :: (IORef (Maybe UserID)),
@@ -82,10 +94,13 @@ on_chvt vtnum = do
 
 start :: IO ()
 start = do
+    tracked <- newIORef Set.empty
+    let dologin e = track_login tracked e
+        dologin :: t -> IO ()
 #ifndef NOUTMP
-    installHandler sigUSR1 (Catch (utmp_event (userError "signaled"))) Nothing
+    installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
 #endif
-    -- installHandler sigTERM (CatchOnce (utmp_event (userError "term signaled"))) Nothing
+    -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
     inotify <- initINotify
     print inotify
 #ifndef NOUTMP
@@ -93,7 +108,7 @@ start = do
             inotify
             [CloseWrite] -- [Open,Close,Access,Modify,Move]
             utmp_file
-            utmp_event
+            dologin
     print wd
 #endif
     mtty <- monitorTTY on_chvt