diff options
-rw-r--r-- | Presence/ConsoleWriter.hs | 204 |
1 files changed, 200 insertions, 4 deletions
diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs index 58474da2..a7c7d55a 100644 --- a/Presence/ConsoleWriter.hs +++ b/Presence/ConsoleWriter.hs | |||
@@ -1,14 +1,121 @@ | |||
1 | module ConsoleWriter where | 1 | {-# LANGUAGE OverloadedStrings #-} |
2 | module ConsoleWriter | ||
3 | ( ConsoleWriter(cwPresenceChan) | ||
4 | , newConsoleWriter | ||
5 | , writeActiveTTY | ||
6 | , writeAllPty | ||
7 | ) where | ||
2 | 8 | ||
3 | import XMPPServer ( Stanza ) | 9 | import Control.Monad |
10 | -- import Control.Applicative | ||
11 | import Control.Concurrent | ||
4 | import Control.Concurrent.STM | 12 | import Control.Concurrent.STM |
13 | import Data.Monoid | ||
14 | import Data.Char | ||
15 | import System.INotify ( initINotify, EventVariety(Modify), addWatch ) | ||
16 | import Data.Word ( Word8 ) | ||
17 | import Data.Text ( Text ) | ||
18 | import Data.Map ( Map ) | ||
19 | import Data.List ( foldl' ) | ||
20 | import qualified Data.Map as Map | ||
21 | import qualified Data.Traversable as Traversable | ||
22 | import qualified Data.Text as Text | ||
23 | -- import qualified Data.Text.IO as Text | ||
24 | import qualified Network.BSD as BSD | ||
5 | 25 | ||
6 | data ConsoleWriter = ConsoleWriter { cwPresenceChan :: TChan Stanza } | 26 | import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) ) |
27 | import FGConsole ( monitorTTY ) | ||
28 | import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..) ) | ||
29 | |||
30 | data ConsoleWriter = ConsoleWriter | ||
31 | { cwPresenceChan :: TChan Stanza | ||
32 | , csActiveTTY :: TVar Word8 | ||
33 | , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord))) | ||
34 | } | ||
35 | |||
36 | tshow x = Text.pack . show $ x | ||
37 | |||
38 | retryWhen var pred = do | ||
39 | value <- var | ||
40 | if pred value then retry | ||
41 | else return value | ||
42 | |||
43 | |||
44 | onLogin cs start = \e -> do | ||
45 | us <- UTmp.users2 | ||
46 | let (m,cruft) = | ||
47 | foldl' (\(m,cruft) x -> | ||
48 | case utmpType x of | ||
49 | USER_PROCESS | ||
50 | -> (Map.insert (utmpTty x) x m,cruft) | ||
51 | DEAD_PROCESS | utmpPid x /= 0 | ||
52 | -> (m,Map.insert (utmpTty x) x cruft) | ||
53 | _ -> (m,cruft)) | ||
54 | (Map.empty,Map.empty) | ||
55 | us | ||
56 | forM_ (Map.elems cruft) $ \c -> do | ||
57 | putStrLn $ "cruft " ++ show (utmpTty c, utmpPid c,utmpHost c, utmpRemoteAddr c) | ||
58 | newborn <- atomically $ do | ||
59 | old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m | ||
60 | newborn <- flip Traversable.mapM (m Map.\\ old) | ||
61 | $ newTVar . Just | ||
62 | updated <- let upd v u = writeTVar v $ Just u | ||
63 | in Traversable.sequence $ Map.intersectionWith upd old m | ||
64 | let dead = old Map.\\ m | ||
65 | Traversable.mapM (flip writeTVar Nothing) dead | ||
66 | writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead | ||
67 | return newborn | ||
68 | let getActive = do | ||
69 | tty <- readTVar $ csActiveTTY cs | ||
70 | utmp <- readTVar $ csUtmp cs | ||
71 | flip (maybe $ return (tty,Nothing)) | ||
72 | (Map.lookup ("tty"<>tshow tty) utmp) | ||
73 | $ \tuvar -> do | ||
74 | tu <- readTVar tuvar | ||
75 | return (tty,tu) | ||
76 | |||
77 | forM_ (Map.elems newborn) $ | ||
78 | forkIO . start getActive | ||
79 | -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show | ||
7 | 80 | ||
8 | newConsoleWriter :: IO ConsoleWriter | 81 | newConsoleWriter :: IO ConsoleWriter |
9 | newConsoleWriter = do | 82 | newConsoleWriter = do |
10 | chan <- atomically newBroadcastTChan | 83 | chan <- atomically newBroadcastTChan |
11 | return ConsoleWriter { cwPresenceChan = chan } | 84 | cs <- atomically $ do |
85 | ttyvar <- newTVar 0 | ||
86 | utmpvar <- newTVar Map.empty | ||
87 | return $ ConsoleWriter { cwPresenceChan = chan | ||
88 | , csActiveTTY = ttyvar | ||
89 | , csUtmp = utmpvar | ||
90 | } | ||
91 | outvar <- atomically $ newTMVar () | ||
92 | let logit outvar s = do | ||
93 | {- | ||
94 | atomically $ takeTMVar outvar | ||
95 | Text.putStrLn s | ||
96 | atomically $ putTMVar outvar () | ||
97 | -} | ||
98 | return () | ||
99 | onTTY outvar cs vtnum = do | ||
100 | logit outvar $ "switch: " <> tshow vtnum | ||
101 | atomically $ writeTVar (csActiveTTY cs) vtnum | ||
102 | |||
103 | inotify <- initINotify | ||
104 | |||
105 | -- get active tty | ||
106 | mtty <- monitorTTY (onTTY outvar cs) | ||
107 | atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0) | ||
108 | |||
109 | -- read utmp | ||
110 | onLogin cs (newCon (logit outvar) cs) Modify | ||
111 | |||
112 | -- monitor utmp | ||
113 | wd <- addWatch | ||
114 | inotify | ||
115 | [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move] | ||
116 | utmp_file | ||
117 | (onLogin cs (newCon (logit outvar) cs)) | ||
118 | return cs | ||
12 | 119 | ||
13 | writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool | 120 | writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool |
14 | writeActiveTTY cw msg = do | 121 | writeActiveTTY cw msg = do |
@@ -20,3 +127,92 @@ writeActiveTTY cw msg = do | |||
20 | writeAllPty :: ConsoleWriter -> Stanza -> IO Bool | 127 | writeAllPty :: ConsoleWriter -> Stanza -> IO Bool |
21 | writeAllPty cw msg = do | 128 | writeAllPty cw msg = do |
22 | return False -- return True if a message was delivered | 129 | return False -- return True if a message was delivered |
130 | |||
131 | resource :: UtmpRecord -> Text | ||
132 | resource u = | ||
133 | case utmpTty u of | ||
134 | s | Text.take 3 s == "tty" -> s | ||
135 | s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u | ||
136 | s -> escapeR s <> ":" <> utmpHost u | ||
137 | where | ||
138 | escapeR s = s | ||
139 | |||
140 | textHostName = fmap Text.pack BSD.getHostName | ||
141 | |||
142 | ujid u = do | ||
143 | h <- textHostName | ||
144 | return $ utmpUser u <> "@" <> h <> "/" <> resource u | ||
145 | |||
146 | newCon :: (Text -> IO ()) | ||
147 | -> ConsoleWriter | ||
148 | -> STM (Word8,Maybe UtmpRecord) | ||
149 | -> TVar (Maybe UtmpRecord) | ||
150 | -> IO () | ||
151 | newCon log cw activeTTY utmp = do | ||
152 | ((tty,tu),u) <- atomically $ | ||
153 | liftM2 (,) activeTTY | ||
154 | (readTVar utmp) | ||
155 | flip (maybe $ return ()) u $ \u -> do | ||
156 | jid <- ujid u | ||
157 | log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u) | ||
158 | <> (if istty (resource u) | ||
159 | then " host=" <> tshow (utmpHost u) | ||
160 | else "") | ||
161 | <> " session=" <> tshow (utmpSession u) | ||
162 | <> " addr=" <> tshow (utmpRemoteAddr u) | ||
163 | loop tty tu (Just u) | ||
164 | where | ||
165 | bstatus r ttynum mtu | ||
166 | = r == ttystr | ||
167 | || match mtu | ||
168 | where ttystr = "tty" <> tshow ttynum | ||
169 | searchstr mtu = maybe ttystr utmpHost $ do | ||
170 | tu <- mtu | ||
171 | guard (not $ Text.null $ utmpHost tu) | ||
172 | return tu | ||
173 | match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r | ||
174 | jstatus r ttynum tu = | ||
175 | if bstatus r ttynum tu | ||
176 | then Available | ||
177 | else Away | ||
178 | status r ttynum tu = tshow $ jstatus r ttynum tu | ||
179 | |||
180 | istty r = fst3 == "tty" && Text.all isDigit rst | ||
181 | where | ||
182 | (fst3,rst) = Text.splitAt 3 r | ||
183 | |||
184 | loop tty tu u = do | ||
185 | what <- atomically $ foldr1 orElse | ||
186 | [ do (tty',tu') <- retryWhen activeTTY | ||
187 | (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu) | ||
188 | return $ ttyChanged tty' tu' | ||
189 | , do u' <- retryWhen (readTVar utmp) (==u) | ||
190 | return $ utmpChanged u' | ||
191 | ] | ||
192 | what | ||
193 | where | ||
194 | r = maybe "" resource u | ||
195 | |||
196 | ttyChanged tty' tu' = do | ||
197 | jid <- maybe (return "") ujid u | ||
198 | stanza <- makePresenceStanza | ||
199 | "jabber:client" | ||
200 | (Just jid) | ||
201 | (jstatus r tty' tu') | ||
202 | atomically $ writeTChan (cwPresenceChan cw) stanza | ||
203 | log $ status r tty' tu' <> " " <> jid | ||
204 | loop tty' tu' u | ||
205 | |||
206 | utmpChanged u' = maybe dead changed u' | ||
207 | where | ||
208 | changed u' = do | ||
209 | jid0 <- maybe (return "") ujid u | ||
210 | jid <- ujid u' | ||
211 | log $ "changed: " <> jid0 <> " --> " <> jid | ||
212 | loop tty tu (Just u') | ||
213 | dead = do | ||
214 | jid <- maybe (return "") ujid u | ||
215 | stanza <- makePresenceStanza "jabber:client" (Just jid) Offline | ||
216 | atomically $ writeTChan (cwPresenceChan cw) stanza | ||
217 | log $ "Offline " <> jid | ||
218 | |||