summaryrefslogtreecommitdiff
path: root/consolation.hs
diff options
context:
space:
mode:
Diffstat (limited to 'consolation.hs')
-rw-r--r--consolation.hs18
1 files changed, 13 insertions, 5 deletions
diff --git a/consolation.hs b/consolation.hs
index 640b51c2..0c6e907a 100644
--- a/consolation.hs
+++ b/consolation.hs
@@ -19,7 +19,7 @@ import qualified Data.Text.IO as Text
19import qualified Network.BSD as BSD 19import qualified Network.BSD as BSD
20 20
21import WaitForSignal ( waitForTermSignal ) 21import WaitForSignal ( waitForTermSignal )
22import UTmp ( users2, utmp_file, UtmpRecord(..) ) 22import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(USER_PROCESS) )
23import FGConsole ( monitorTTY ) 23import FGConsole ( monitorTTY )
24 24
25data ConsoleState = ConsoleState 25data ConsoleState = ConsoleState
@@ -33,7 +33,13 @@ newConsoleState = atomically $
33 33
34onLogin cs start = \e -> do 34onLogin cs start = \e -> do
35 us <- UTmp.users2 35 us <- UTmp.users2
36 let m = foldl' (\m x -> Map.insert (utmpTty x) x m) Map.empty us 36 let (m,cruft) =
37 foldl' (\(m,cruft) x ->
38 if utmpType x==USER_PROCESS
39 then (Map.insert (utmpTty x) x m,cruft)
40 else (m,Map.insert (utmpTty x) x cruft))
41 (Map.empty,Map.empty)
42 us
37 newborn <- atomically $ do 43 newborn <- atomically $ do
38 old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m 44 old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m
39 newborn <- flip Traversable.mapM (m Map.\\ old) 45 newborn <- flip Traversable.mapM (m Map.\\ old)
@@ -89,9 +95,11 @@ newCon log activeTTY utmp = do
89 flip (maybe $ return ()) u $ \u -> do 95 flip (maybe $ return ()) u $ \u -> do
90 jid <- ujid u 96 jid <- ujid u
91 log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u) 97 log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u)
92 <> if istty (resource u) 98 <> (if istty (resource u)
93 then " host=" <> tshow (utmpHost u) 99 then " host=" <> tshow (utmpHost u)
94 else "" 100 else "")
101 <> " session=" <> tshow (utmpSession u)
102 <> " addr=" <> utmpRemoteAddr u
95 loop tty tu (Just u) 103 loop tty tu (Just u)
96 where 104 where
97 bstatus r ttynum mtu 105 bstatus r ttynum mtu