summaryrefslogtreecommitdiff
path: root/Presence/ConsoleWriter.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/ConsoleWriter.hs')
-rw-r--r--Presence/ConsoleWriter.hs420
1 files changed, 0 insertions, 420 deletions
diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
deleted file mode 100644
index c6e1871a..00000000
--- a/Presence/ConsoleWriter.hs
+++ /dev/null
@@ -1,420 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
4module ConsoleWriter
5 ( ConsoleWriter(cwPresenceChan)
6 , newConsoleWriter
7 , writeActiveTTY
8 , writeAllPty
9 , cwClients
10 ) where
11
12import Control.Monad
13-- import Control.Applicative
14import Control.Concurrent
15import Control.Concurrent.STM
16import Data.Monoid
17import Data.Char
18import Data.Maybe
19import System.Environment hiding (setEnv)
20import System.Exit ( ExitCode(ExitSuccess) )
21import System.Posix.Env ( setEnv )
22import System.Posix.Process ( forkProcess, exitImmediately, executeFile )
23import System.Posix.User ( setUserID, getUserEntryForName, userID )
24import System.Posix.Files ( getFileStatus, fileMode )
25import System.INotify ( initINotify, EventVariety(Modify), addWatch )
26import System.IO.Error
27import Data.Word ( Word8 )
28import Data.Text ( Text )
29import Data.Map ( Map )
30import Data.List ( foldl', groupBy )
31import Data.Bits ( (.&.) )
32import qualified Data.Map as Map
33import qualified Data.Traversable as Traversable
34import qualified Data.Text as Text
35-- import qualified Data.Text.IO as Text
36import qualified Network.BSD as BSD
37
38import DPut
39import DebugTag
40import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
41import FGConsole ( forkTTYMonitor )
42import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
43 , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
44import ControlMaybe
45import ClientState
46
47data ConsoleWriter = ConsoleWriter
48 { cwPresenceChan :: TMVar (ClientState,Stanza)
49 -- ^ tty switches and logins are announced on this mvar
50 , csActiveTTY :: TVar Word8
51 , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
52 , cwClients :: TVar (Map Text ClientState)
53 -- ^ This 'TVar' holds a map from resource id (tty name)
54 -- to ClientState for all active TTYs and PTYs.
55 }
56
57tshow :: forall a. Show a => a -> Text
58tshow x = Text.pack . show $ x
59
60retryWhen :: forall b. STM b -> (b -> Bool) -> STM b
61retryWhen var pred = do
62 value <- var
63 if pred value then retry
64 else return value
65
66
67onLogin ::
68 forall t.
69 ConsoleWriter
70 -> (STM (Word8, Maybe UtmpRecord)
71 -> TVar (Maybe UtmpRecord) -> IO ())
72 -> t
73 -> IO ()
74onLogin cs start = \e -> do
75 us <- UTmp.users2
76 let (m,cruft) =
77 foldl' (\(m,cruft) x ->
78 case utmpType x of
79 USER_PROCESS
80 -> (Map.insert (utmpTty x) x m,cruft)
81 DEAD_PROCESS | utmpPid x /= 0
82 -> (m,Map.insert (utmpTty x) x cruft)
83 _ -> (m,cruft))
84 (Map.empty,Map.empty)
85 us
86 forM_ (Map.elems cruft) $ \c -> do
87 putStrLn $ "cruft " ++ show (utmpTty c, utmpPid c,utmpHost c, utmpRemoteAddr c)
88 newborn <- atomically $ do
89 old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m
90 newborn <- flip Traversable.mapM (m Map.\\ old)
91 $ newTVar . Just
92 updated <- let upd v u = writeTVar v $ Just u
93 in Traversable.sequence $ Map.intersectionWith upd old m
94 let dead = old Map.\\ m
95 Traversable.mapM (flip writeTVar Nothing) dead
96 writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead
97 return newborn
98 let getActive = do
99 tty <- readTVar $ csActiveTTY cs
100 utmp <- readTVar $ csUtmp cs
101 fromMaybe (return (tty,Nothing))
102 $ Map.lookup ("tty"<>tshow tty) utmp <&> \tuvar -> do
103 tu <- readTVar tuvar
104 return (tty,tu)
105
106 forM_ (Map.elems newborn) $
107 forkIO . start getActive
108 -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show
109
110-- | Sets up threads to monitor tty switches and logins that are
111-- written to the system utmp file and returns a 'ConsoleWriter'
112-- object for interacting with that information.
113newConsoleWriter :: IO (Maybe ConsoleWriter)
114newConsoleWriter = do
115 chan <- atomically $ newEmptyTMVar
116 cs <- atomically $ do
117 ttyvar <- newTVar 0
118 utmpvar <- newTVar Map.empty
119 clients <- newTVar Map.empty
120 return $ ConsoleWriter { cwPresenceChan = chan
121 , csActiveTTY = ttyvar
122 , csUtmp = utmpvar
123 , cwClients = clients
124 }
125 outvar <- atomically $ newTMVar ()
126 let logit outvar s = do
127 {-
128 atomically $ takeTMVar outvar
129 Text.putStrLn s
130 atomically $ putTMVar outvar ()
131 -}
132 return ()
133 onTTY outvar cs vtnum = do
134 logit outvar $ "switch: " <> tshow vtnum
135 atomically $ writeTVar (csActiveTTY cs) vtnum
136
137 inotify <- initINotify
138
139 -- get active tty
140 mtty <- forkTTYMonitor (onTTY outvar cs)
141 forM mtty $ \_ -> do
142 atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0)
143
144 -- read utmp
145 onLogin cs (newCon (logit outvar) cs) Modify
146
147 -- monitor utmp
148 wd <- addWatch
149 inotify
150 [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move]
151 utmp_file
152 (onLogin cs (newCon (logit outvar) cs))
153 return cs
154
155-- Transforms a string of form language[_territory][.codeset][@modifier]
156-- typically used in LC_ locale variables into the BCP 47
157-- language codes used in xml:lang attributes.
158toBCP47 :: [Char] -> [Char]
159toBCP47 lang = map hyphen $ takeWhile (/='.') lang
160 where hyphen '_' = '-'
161 hyphen c = c
162
163#if MIN_VERSION_base(4,6,0)
164#else
165lookupEnv k = fmap (lookup k) getEnvironment
166#endif
167
168getPreferedLang :: IO Text
169getPreferedLang = do
170 lang <- do
171 lc_all <- lookupEnv "LC_ALL"
172 lc_messages <- lookupEnv "LC_MESSAGES"
173 lang <- lookupEnv "LANG"
174 return $ lc_all `mplus` lc_messages `mplus` lang
175 return $ maybe "en" (Text.pack . toBCP47) lang
176
177cimatch :: Text -> Text -> Bool
178cimatch w t = Text.toLower w == Text.toLower t
179
180cimatches :: Text -> [Text] -> [Text]
181cimatches w ts = dropWhile (not . cimatch w) ts
182
183-- rfc4647 lookup of best match language tag
184lookupLang :: [Text] -> [Text] -> Maybe Text
185lookupLang (w:ws) tags
186 | Text.null w = lookupLang ws tags
187 | otherwise = case cimatches w tags of
188 (t:_) -> Just t
189 [] -> lookupLang (reduce w:ws) tags
190 where
191 reduce w = Text.concat $ reverse nopriv
192 where
193 rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w
194 nopriv = dropWhile ispriv rparts
195 ispriv t = Text.length t == 2 && Text.head t == '-'
196
197lookupLang [] tags | "" `elem` tags = Just ""
198 | otherwise = listToMaybe $ tags
199
200
201messageText :: Stanza -> IO Text
202messageText msg = do
203 pref <- getPreferedLang
204 let m = msgLangMap (stanzaType msg)
205 key = lookupLang [pref] (map fst m)
206 mchoice = do
207 k <- key
208 lookup k m
209 return $ fromMaybe "" $ do
210 choice <- mchoice
211 let subj = fmap ("Subject: " <>) $ msgSubject choice
212 ts = catMaybes [subj, msgBody choice]
213 return $ Text.intercalate "\n\n" ts
214
215readEnvFile :: String -> FilePath -> IO (Maybe String)
216readEnvFile var file = fmap parse $ readFile file
217 where
218 parse xs = listToMaybe $ map (drop 1 . concat . drop 1) $ filter ofinterest bs
219 where
220 bs = map (groupBy (\_ x -> x/='=')) $ split (/='\0') xs
221 ofinterest (k:vs) | k==var = True
222 ofinterest _ = False
223
224 split pred xs = take 1 gs ++ map (drop 1) (drop 1 gs)
225 where
226 gs = groupBy (\_ x -> pred x) xs
227
228-- | Delivers an XMPP message stanza to the currently active
229-- tty. If that is a linux console, it will write to it similar
230-- to the manner of the BSD write command. If that is an X11
231-- display, it will attempt to notify the user via a libnotify
232-- interface.
233writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
234writeActiveTTY cw msg = do
235 putStrLn $ "writeActiveTTY"
236 -- TODO: Do not deliver if the detination user does not own the active tty!
237 (tty, mbu) <- atomically $ do
238 num <- readTVar $ csActiveTTY cw
239 utmp <- readTVar $ csUtmp cw
240 mbu <- maybe (return Nothing) readTVar
241 $ Map.lookup ("tty"<>tshow num) utmp
242 return ( "/dev/tty" <> tshow num
243 , mbu )
244 fromMaybe (return False) $ mbu <&> \utmp -> do
245 display <- fmap (fmap Text.pack)
246 $ readEnvFile "DISPLAY" ("/proc/" ++ show (utmpPid utmp) ++ "/environ")
247 case fmap (==utmpHost utmp) display of
248 Just True -> deliverGUIMessage cw tty utmp msg
249 _ -> deliverTerminalMessage cw tty utmp msg
250
251deliverGUIMessage ::
252 forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool
253deliverGUIMessage cw tty utmp msg = do
254 text <- do
255 t <- messageText msg
256 return $ Text.unpack
257 $ case stanzaFrom msg of
258 Just from -> from <> ": " <> t
259 Nothing -> t
260 putStrLn $ "deliverGUI: " ++ text
261 handleIO_ (return False) $ do
262 muentry <- fmap Just (getUserEntryForName (Text.unpack $ utmpUser utmp))
263 `catchIOError` \e -> do
264 dput XJabber $ "deliverGUIMessage(getUserEntryForName "++show (utmpUser utmp)++"): "++show e
265 return Nothing
266 forM_ muentry $ \uentry -> do
267 let display = Text.unpack $ utmpHost utmp
268 pid <- forkProcess $ do
269 setUserID (userID uentry)
270 setEnv "DISPLAY" display True
271 -- rawSystem "/usr/bin/notify-send" [text]
272 executeFile "/usr/bin/notify-send" False [text] (Just [("DISPLAY",display)])
273 exitImmediately ExitSuccess
274 return ()
275 return True
276
277crlf :: Text -> Text
278crlf t = Text.unlines $ map cr (Text.lines t)
279 where
280 cr t | Text.last t == '\r' = t
281 | otherwise = t <> "\r"
282
283deliverTerminalMessage ::
284 forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
285deliverTerminalMessage cw tty utmp msg = do
286 mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
287 let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
288 if not mesgy then return False else do
289 text <- do
290 t <- messageText msg
291 return $ Text.unpack
292 $ case stanzaFrom msg of
293 Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n"
294 Nothing -> crlf t <> "\r\n"
295 writeFile (Text.unpack tty) text
296 return True -- return True if a message was delivered
297
298-- | Deliver the given message to all a user's PTYs.
299writeAllPty :: ConsoleWriter -> Stanza -> IO Bool
300writeAllPty cw msg = do
301 -- TODO: filter only ptys owned by the destination user.
302 us <- atomically $ readTVar (csUtmp cw)
303 let ptys = Map.filterWithKey ispty us
304 ispty k _ = "pts/" `Text.isPrefixOf` k
305 && Text.all isDigit (Text.drop 4 k)
306 bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do
307 deliverTerminalMessage cw ("/dev/" <> tty) utmp msg
308 return $ or bs
309
310resource :: UtmpRecord -> Text
311resource u =
312 case utmpTty u of
313 s | Text.take 3 s == "tty" -> s
314 s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u
315 s -> escapeR s <> ":" <> utmpHost u
316 where
317 escapeR s = s
318
319textHostName :: IO Text
320textHostName = fmap Text.pack BSD.getHostName
321
322ujid :: UtmpRecord -> IO Text
323ujid u = do
324 h <- textHostName
325 return $ utmpUser u <> "@" <> h <> "/" <> resource u
326
327newCon :: (Text -> IO ())
328 -> ConsoleWriter
329 -> STM (Word8,Maybe UtmpRecord)
330 -> TVar (Maybe UtmpRecord)
331 -> IO ()
332newCon log cw activeTTY utmp = do
333 ((tty,tu),u) <- atomically $
334 liftM2 (,) activeTTY
335 (readTVar utmp)
336 forM_ u $ \u -> do
337 jid <- ujid u
338 log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u)
339 <> (if istty (resource u)
340 then " host=" <> tshow (utmpHost u)
341 else "")
342 <> " session=" <> tshow (utmpSession u)
343 <> " addr=" <> tshow (utmpRemoteAddr u)
344 let r = resource u
345 stanza <- makePresenceStanza
346 "jabber:client"
347 (Just jid)
348 (jstatus r tty tu)
349 statusv <- atomically $ newTVar (Just stanza)
350 flgs <- atomically $ newTVar 0
351 let client = ClientState { clientResource = r
352 , clientUser = utmpUser u
353 , clientProfile = "."
354 , clientPid = Nothing
355 , clientStatus = statusv
356 , clientFlags = flgs }
357 atomically $ do
358 modifyTVar (cwClients cw) $ Map.insert r client
359 putTMVar (cwPresenceChan cw) (client,stanza)
360 loop client tty tu (Just u)
361 where
362 bstatus r ttynum mtu
363 = r == ttystr
364 || match mtu
365 where ttystr = "tty" <> tshow ttynum
366 searchstr mtu = maybe ttystr utmpHost $ do
367 tu <- mtu
368 guard (not $ Text.null $ utmpHost tu)
369 return tu
370 match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r
371 jstatus r ttynum tu =
372 if bstatus r ttynum tu
373 then Available
374 else Away
375 status r ttynum tu = tshow $ jstatus r ttynum tu
376
377 istty r = fst3 == "tty" && Text.all isDigit rst
378 where
379 (fst3,rst) = Text.splitAt 3 r
380
381 loop client tty tu u = do
382 what <- atomically $ foldr1 orElse
383 [ do (tty',tu') <- retryWhen activeTTY
384 (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu)
385 return $ ttyChanged tty' tu'
386 , do u' <- retryWhen (readTVar utmp) (==u)
387 return $ utmpChanged u'
388 ]
389 what
390 where
391 r = maybe "" resource u
392
393 ttyChanged tty' tu' = do
394 jid <- maybe (return "") ujid u
395 stanza <- makePresenceStanza
396 "jabber:client"
397 (Just jid)
398 (jstatus r tty' tu')
399 dup <- cloneStanza stanza
400 atomically $ do
401 writeTVar (clientStatus client) $ Just dup
402 putTMVar (cwPresenceChan cw) (client,stanza)
403 log $ status r tty' tu' <> " " <> jid
404 loop client tty' tu' u
405
406 utmpChanged u' = maybe dead changed u'
407 where
408 changed u' = do
409 jid0 <- maybe (return "") ujid u
410 jid <- ujid u'
411 log $ "changed: " <> jid0 <> " --> " <> jid
412 loop client tty tu (Just u')
413 dead = do
414 jid <- maybe (return "") ujid u
415 stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
416 atomically $ do
417 modifyTVar (cwClients cw) $ Map.delete (clientResource client)
418 putTMVar (cwPresenceChan cw) (client,stanza)
419 log $ "Offline " <> jid
420
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 15:53:37 +0000