diff options
-rw-r--r-- | consolation.hs | 68 |
1 files changed, 53 insertions, 15 deletions
diff --git a/consolation.hs b/consolation.hs index a248098a..bced2839 100644 --- a/consolation.hs +++ b/consolation.hs | |||
@@ -14,6 +14,8 @@ import Data.List ( foldl' ) | |||
14 | import qualified Data.Map as Map | 14 | import qualified Data.Map as Map |
15 | import qualified Data.Traversable as Traversable | 15 | import qualified Data.Traversable as Traversable |
16 | import qualified Data.Text as Text | 16 | import qualified Data.Text as Text |
17 | import qualified Data.Text.IO as Text | ||
18 | import qualified Network.BSD as BSD | ||
17 | 19 | ||
18 | import WaitForSignal ( waitForTermSignal ) | 20 | import WaitForSignal ( waitForTermSignal ) |
19 | import UTmp ( users2, utmp_file, UtmpRecord(..) ) | 21 | import UTmp ( users2, utmp_file, UtmpRecord(..) ) |
@@ -52,20 +54,38 @@ retryWhen var pred = do | |||
52 | if pred value then retry | 54 | if pred value then retry |
53 | else return value | 55 | else return value |
54 | 56 | ||
55 | newCon activeTTY utmp = do | 57 | tshow x = Text.pack . show $ x |
58 | |||
59 | resource :: UtmpRecord -> Text | ||
60 | resource u = | ||
61 | case utmpTty u of | ||
62 | s | Text.take 3 s == "tty" -> s | ||
63 | s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u | ||
64 | s -> escapeR s <> ":" <> utmpHost u | ||
65 | where | ||
66 | escapeR s = s | ||
67 | |||
68 | textHostName = fmap Text.pack BSD.getHostName | ||
69 | |||
70 | ujid u = do | ||
71 | h <- textHostName | ||
72 | return $ utmpUser u <> "@" <> h <> "/" <> resource u | ||
73 | |||
74 | newCon :: (Text -> IO ()) -> TVar Word8 -> TVar (Maybe UtmpRecord) -> IO () | ||
75 | newCon log activeTTY utmp = do | ||
56 | (tty,u) <- atomically $ | 76 | (tty,u) <- atomically $ |
57 | liftM2 (,) (readTVar activeTTY) | 77 | liftM2 (,) (readTVar activeTTY) |
58 | (readTVar utmp) | 78 | (readTVar utmp) |
59 | putStrLn $ resource u ++ ": " ++ status (resource u) tty ++ " " ++ show u | 79 | flip (maybe $ return ()) u $ \u -> do |
60 | loop tty u | 80 | jid <- ujid u |
81 | log $ status (resource u) tty <> " " <> jid <> " pid=" <> tshow (utmpPid u) | ||
82 | loop tty (Just u) | ||
61 | where | 83 | where |
62 | bstatus r ttynum = r == "tty" ++ show ttynum | 84 | bstatus r ttynum = r == "tty" <> tshow ttynum |
63 | status r ttynum = | 85 | status r ttynum = |
64 | if bstatus r ttynum | 86 | if bstatus r ttynum |
65 | then "Available" | 87 | then "Available" |
66 | else "Away" | 88 | else "Away " |
67 | |||
68 | resource u = maybe "" (Text.unpack . utmpTty) u | ||
69 | 89 | ||
70 | loop tty u = do | 90 | loop tty u = do |
71 | what <- atomically $ foldr1 orElse | 91 | what <- atomically $ foldr1 orElse |
@@ -77,31 +97,49 @@ newCon activeTTY utmp = do | |||
77 | ] | 97 | ] |
78 | what | 98 | what |
79 | where | 99 | where |
80 | r = resource u | 100 | r = maybe "" resource u |
81 | 101 | ||
82 | ttyChanged tty' = do | 102 | ttyChanged tty' = do |
83 | putStrLn $ r ++ ": " ++ status r tty' | 103 | jid <- maybe (return "") ujid u |
104 | log $ status r tty' <> " " <> jid | ||
84 | loop tty' u | 105 | loop tty' u |
85 | 106 | ||
86 | utmpChanged u' = maybe dead changed u' | 107 | utmpChanged u' = maybe dead changed u' |
87 | where | 108 | where |
88 | changed u' = do | 109 | changed u' = do |
89 | putStrLn $ r ++ " changed: " ++ show u' | 110 | jid0 <- maybe (return "") ujid u |
111 | jid <- ujid u' | ||
112 | log $ "changed: " <> jid0 <> " --> " <> jid | ||
90 | loop tty (Just u') | 113 | loop tty (Just u') |
91 | dead = do | 114 | dead = do |
92 | putStrLn $ r ++ ": Offline" | 115 | jid <- maybe (return "") ujid u |
116 | log $ "Offline " <> jid | ||
117 | |||
118 | logit outvar s = do | ||
119 | atomically $ takeTMVar outvar | ||
120 | Text.putStrLn s | ||
121 | atomically $ putTMVar outvar () | ||
122 | |||
93 | 123 | ||
94 | main = do | 124 | main = do |
125 | outvar <- atomically $ newTMVar () | ||
126 | |||
95 | cs <- newConsoleState | 127 | cs <- newConsoleState |
96 | inotify <- initINotify | 128 | inotify <- initINotify |
97 | onLogin cs newCon Modify -- initialize utmp records | 129 | |
130 | -- get active tty | ||
131 | mtty <- monitorTTY (onTTY cs) | ||
132 | atomically $ retryWhen (csActiveTTY cs) (==0) | ||
133 | |||
134 | -- read utmp | ||
135 | onLogin cs (newCon $ logit outvar) Modify | ||
136 | |||
137 | -- monitor utmp | ||
98 | wd <- addWatch | 138 | wd <- addWatch |
99 | inotify | 139 | inotify |
100 | [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move] | 140 | [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move] |
101 | utmp_file | 141 | utmp_file |
102 | (onLogin cs newCon) -- update utmp records | 142 | (onLogin cs (newCon $ logit outvar)) |
103 | |||
104 | mtty <- monitorTTY (onTTY cs) | ||
105 | 143 | ||
106 | waitForTermSignal | 144 | waitForTermSignal |
107 | 145 | ||