From 09a7695feba9da4cc051219564dc9a9a8dc2dfc4 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 14 Mar 2014 16:15:28 -0400 Subject: console presence implemented --- Presence/ConsoleWriter.hs | 204 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 200 insertions(+), 4 deletions(-) (limited to 'Presence/ConsoleWriter.hs') 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 @@ -module ConsoleWriter where +{-# LANGUAGE OverloadedStrings #-} +module ConsoleWriter + ( ConsoleWriter(cwPresenceChan) + , newConsoleWriter + , writeActiveTTY + , writeAllPty + ) where -import XMPPServer ( Stanza ) +import Control.Monad +-- import Control.Applicative +import Control.Concurrent import Control.Concurrent.STM +import Data.Monoid +import Data.Char +import System.INotify ( initINotify, EventVariety(Modify), addWatch ) +import Data.Word ( Word8 ) +import Data.Text ( Text ) +import Data.Map ( Map ) +import Data.List ( foldl' ) +import qualified Data.Map as Map +import qualified Data.Traversable as Traversable +import qualified Data.Text as Text +-- import qualified Data.Text.IO as Text +import qualified Network.BSD as BSD -data ConsoleWriter = ConsoleWriter { cwPresenceChan :: TChan Stanza } +import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) ) +import FGConsole ( monitorTTY ) +import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..) ) + +data ConsoleWriter = ConsoleWriter + { cwPresenceChan :: TChan Stanza + , csActiveTTY :: TVar Word8 + , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord))) + } + +tshow x = Text.pack . show $ x + +retryWhen var pred = do + value <- var + if pred value then retry + else return value + + +onLogin cs start = \e -> do + us <- UTmp.users2 + let (m,cruft) = + foldl' (\(m,cruft) x -> + case utmpType x of + USER_PROCESS + -> (Map.insert (utmpTty x) x m,cruft) + DEAD_PROCESS | utmpPid x /= 0 + -> (m,Map.insert (utmpTty x) x cruft) + _ -> (m,cruft)) + (Map.empty,Map.empty) + us + forM_ (Map.elems cruft) $ \c -> do + putStrLn $ "cruft " ++ show (utmpTty c, utmpPid c,utmpHost c, utmpRemoteAddr c) + newborn <- atomically $ do + old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m + newborn <- flip Traversable.mapM (m Map.\\ old) + $ newTVar . Just + updated <- let upd v u = writeTVar v $ Just u + in Traversable.sequence $ Map.intersectionWith upd old m + let dead = old Map.\\ m + Traversable.mapM (flip writeTVar Nothing) dead + writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead + return newborn + let getActive = do + tty <- readTVar $ csActiveTTY cs + utmp <- readTVar $ csUtmp cs + flip (maybe $ return (tty,Nothing)) + (Map.lookup ("tty"<>tshow tty) utmp) + $ \tuvar -> do + tu <- readTVar tuvar + return (tty,tu) + + forM_ (Map.elems newborn) $ + forkIO . start getActive + -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show newConsoleWriter :: IO ConsoleWriter newConsoleWriter = do chan <- atomically newBroadcastTChan - return ConsoleWriter { cwPresenceChan = chan } + cs <- atomically $ do + ttyvar <- newTVar 0 + utmpvar <- newTVar Map.empty + return $ ConsoleWriter { cwPresenceChan = chan + , csActiveTTY = ttyvar + , csUtmp = utmpvar + } + outvar <- atomically $ newTMVar () + let logit outvar s = do + {- + atomically $ takeTMVar outvar + Text.putStrLn s + atomically $ putTMVar outvar () + -} + return () + onTTY outvar cs vtnum = do + logit outvar $ "switch: " <> tshow vtnum + atomically $ writeTVar (csActiveTTY cs) vtnum + + inotify <- initINotify + + -- get active tty + mtty <- monitorTTY (onTTY outvar cs) + atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0) + + -- read utmp + onLogin cs (newCon (logit outvar) cs) Modify + + -- monitor utmp + wd <- addWatch + inotify + [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move] + utmp_file + (onLogin cs (newCon (logit outvar) cs)) + return cs writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool writeActiveTTY cw msg = do @@ -20,3 +127,92 @@ writeActiveTTY cw msg = do writeAllPty :: ConsoleWriter -> Stanza -> IO Bool writeAllPty cw msg = do return False -- return True if a message was delivered + +resource :: UtmpRecord -> Text +resource u = + case utmpTty u of + s | Text.take 3 s == "tty" -> s + s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u + s -> escapeR s <> ":" <> utmpHost u + where + escapeR s = s + +textHostName = fmap Text.pack BSD.getHostName + +ujid u = do + h <- textHostName + return $ utmpUser u <> "@" <> h <> "/" <> resource u + +newCon :: (Text -> IO ()) + -> ConsoleWriter + -> STM (Word8,Maybe UtmpRecord) + -> TVar (Maybe UtmpRecord) + -> IO () +newCon log cw activeTTY utmp = do + ((tty,tu),u) <- atomically $ + liftM2 (,) activeTTY + (readTVar utmp) + flip (maybe $ return ()) u $ \u -> do + jid <- ujid u + log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u) + <> (if istty (resource u) + then " host=" <> tshow (utmpHost u) + else "") + <> " session=" <> tshow (utmpSession u) + <> " addr=" <> tshow (utmpRemoteAddr u) + loop tty tu (Just u) + where + bstatus r ttynum mtu + = r == ttystr + || match mtu + where ttystr = "tty" <> tshow ttynum + searchstr mtu = maybe ttystr utmpHost $ do + tu <- mtu + guard (not $ Text.null $ utmpHost tu) + return tu + match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r + jstatus r ttynum tu = + if bstatus r ttynum tu + then Available + else Away + status r ttynum tu = tshow $ jstatus r ttynum tu + + istty r = fst3 == "tty" && Text.all isDigit rst + where + (fst3,rst) = Text.splitAt 3 r + + loop tty tu u = do + what <- atomically $ foldr1 orElse + [ do (tty',tu') <- retryWhen activeTTY + (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu) + return $ ttyChanged tty' tu' + , do u' <- retryWhen (readTVar utmp) (==u) + return $ utmpChanged u' + ] + what + where + r = maybe "" resource u + + ttyChanged tty' tu' = do + jid <- maybe (return "") ujid u + stanza <- makePresenceStanza + "jabber:client" + (Just jid) + (jstatus r tty' tu') + atomically $ writeTChan (cwPresenceChan cw) stanza + log $ status r tty' tu' <> " " <> jid + loop tty' tu' u + + utmpChanged u' = maybe dead changed u' + where + changed u' = do + jid0 <- maybe (return "") ujid u + jid <- ujid u' + log $ "changed: " <> jid0 <> " --> " <> jid + loop tty tu (Just u') + dead = do + jid <- maybe (return "") ujid u + stanza <- makePresenceStanza "jabber:client" (Just jid) Offline + atomically $ writeTChan (cwPresenceChan cw) stanza + log $ "Offline " <> jid + -- cgit v1.2.3