path: root/Presence/ConsoleWriter.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module ConsoleWriter
    ( ConsoleWriter(cwPresenceChan)
    , newConsoleWriter
    , writeActiveTTY
    , writeAllPty
    , cwClients
    ) where

import Control.Monad
-- import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Data.Monoid
import Data.Char
import Data.Maybe
import System.Environment hiding (setEnv)
import System.Exit ( ExitCode(ExitSuccess) )
import System.Posix.Env     ( setEnv )
import System.Posix.Process ( forkProcess, exitImmediately, executeFile )
import System.Posix.User  ( setUserID, getUserEntryForName, userID )
import System.Posix.Files ( getFileStatus, fileMode )
import System.INotify ( initINotify, EventVariety(Modify), addWatch )
import Data.Word      ( Word8 )
import Data.Text      ( Text )
import Data.Map       ( Map )
import Data.List      ( foldl', groupBy )
import Data.Bits      ( (.&.) )
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

import UTmp           ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
import FGConsole      ( forkTTYMonitor )
import XMPPServer     ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
                      , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
import ControlMaybe
import ClientState

data ConsoleWriter = ConsoleWriter
    { cwPresenceChan :: TMVar (ClientState,Stanza)
    -- ^ tty switches and logins are announced on this mvar
    , csActiveTTY :: TVar Word8
    , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
    , cwClients :: TVar (Map Text ClientState)
    -- ^ This 'TVar' holds a map from resource id (tty name)
    --   to ClientState for all active TTYs and PTYs.
    }

tshow :: forall a. Show a => a -> Text
tshow x = Text.pack . show $ x

retryWhen :: forall b. STM b -> (b -> Bool) -> STM b
retryWhen var pred = do
    value <- var
    if pred value then retry
                  else return value


onLogin ::
    forall t.
    ConsoleWriter
    -> (STM (Word8, Maybe UtmpRecord)
        -> TVar (Maybe UtmpRecord) -> IO ())
    -> t
    -> IO ()
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
            fromMaybe (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

-- | Sets up threads to monitor tty switches and logins that are
-- written to the system utmp file and returns a 'ConsoleWriter'
-- object for interacting with that information.
newConsoleWriter :: IO (Maybe ConsoleWriter)
newConsoleWriter = do
    chan <- atomically $ newEmptyTMVar
    cs <- atomically $ do
        ttyvar <- newTVar 0
        utmpvar <- newTVar Map.empty
        clients <- newTVar Map.empty
        return $ ConsoleWriter { cwPresenceChan = chan
                               , csActiveTTY = ttyvar
                               , csUtmp = utmpvar
                               , cwClients = clients
                               }
    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 <- forkTTYMonitor (onTTY outvar cs)
    forM mtty $ \_ -> do
    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

-- Transforms a string of form language[_territory][.codeset][@modifier]
-- typically used in LC_ locale variables into the BCP 47
-- language codes used in xml:lang attributes.
toBCP47 :: [Char] -> [Char]
toBCP47 lang = map hyphen $ takeWhile (/='.') lang
 where hyphen '_' = '-'
       hyphen  c  =  c

#if MIN_VERSION_base(4,6,0)
#else
lookupEnv k = fmap (lookup k) getEnvironment
#endif

getPreferedLang :: IO Text
getPreferedLang = do
    lang <- do
        lc_all <- lookupEnv "LC_ALL"
        lc_messages <- lookupEnv "LC_MESSAGES"
        lang <- lookupEnv "LANG"
        return $ lc_all `mplus` lc_messages `mplus` lang
    return $ maybe "en" (Text.pack . toBCP47) lang

cimatch :: Text -> Text -> Bool
cimatch w t = Text.toLower w == Text.toLower t

cimatches :: Text -> [Text] -> [Text]
cimatches w ts = dropWhile (not . cimatch w) ts

-- rfc4647 lookup of best match language tag
lookupLang :: [Text] -> [Text] -> Maybe Text
lookupLang (w:ws) tags
    | Text.null w = lookupLang ws tags
    | otherwise   = case cimatches w tags of
                        (t:_) -> Just t
                        []    -> lookupLang (reduce w:ws) tags
 where
    reduce w = Text.concat $ reverse nopriv
        where
            rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w
            nopriv = dropWhile ispriv rparts
            ispriv t = Text.length t == 2 && Text.head t == '-'

lookupLang [] tags | "" `elem` tags = Just ""
                   | otherwise      = listToMaybe $ tags


messageText :: Stanza -> IO Text
messageText msg = do
    pref <- getPreferedLang
    let m = msgLangMap (stanzaType msg)
        key = lookupLang [pref] (map fst m)
        mchoice = do
            k <- key
            lookup k m
    return $ fromMaybe "" $ do
        choice <- mchoice
        let subj = fmap ("Subject: " <>) $ msgSubject choice
            ts = catMaybes [subj, msgBody choice]
        return $ Text.intercalate "\n\n" ts

readEnvFile :: String -> FilePath -> IO (Maybe String)
readEnvFile var file = fmap parse $ readFile file
 where
    parse xs = listToMaybe $ map (drop 1 . concat . drop 1) $ filter ofinterest bs
     where
        bs = map (groupBy (\_ x -> x/='=')) $ split (/='\0') xs
        ofinterest (k:vs) | k==var = True
        ofinterest _               = False

    split pred xs = take 1 gs ++ map (drop 1) (drop 1 gs)
     where
        gs = groupBy (\_ x -> pred x) xs

-- | Delivers an XMPP message stanza to the currently active
-- tty.  If that is a linux console, it will write to it similar
-- to the manner of the BSD write command.  If that is an X11
-- display, it will attempt to notify the user via a libnotify
-- interface.
writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
writeActiveTTY cw msg = do
    putStrLn $ "writeActiveTTY"
    -- TODO: Do not deliver if the detination user does not own the active tty!
    (tty, mbu) <- atomically $ do
                num <- readTVar $ csActiveTTY cw
                utmp <- readTVar $ csUtmp cw
                mbu <- maybe (return Nothing) readTVar
                        $ Map.lookup ("tty"<>tshow num) utmp
                return ( "/dev/tty" <> tshow num
                       , mbu )
    fromMaybe (return False) $ mbu <&> \utmp -> do
    display <- fmap (fmap Text.pack)
        $ readEnvFile "DISPLAY" ("/proc/" ++ show (utmpPid utmp) ++ "/environ")
    case fmap (==utmpHost utmp) display of
        Just True -> deliverGUIMessage cw tty utmp msg
        _ -> deliverTerminalMessage cw tty utmp msg

deliverGUIMessage ::
    forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool
deliverGUIMessage cw tty utmp msg = do
    text <- do
        t <- messageText msg
        return $ Text.unpack
            $ case stanzaFrom msg of
                Just from -> from <> ": " <> t
                Nothing -> t
    putStrLn $ "deliverGUI: " ++ text
    handleIO_ (return False) $ do
    uentry <- getUserEntryForName (Text.unpack $ utmpUser utmp)
    let display = Text.unpack $ utmpHost utmp
    pid <- forkProcess $ do
        setUserID (userID uentry)
        setEnv "DISPLAY" display True
        -- rawSystem "/usr/bin/notify-send" [text]
        executeFile "/usr/bin/notify-send" False [text] (Just [("DISPLAY",display)])
        exitImmediately ExitSuccess
    return True

crlf :: Text -> Text
crlf t = Text.unlines $ map cr (Text.lines t)
 where
    cr t | Text.last t == '\r'  = t
         | otherwise            = t <> "\r"

deliverTerminalMessage ::
    forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
deliverTerminalMessage cw tty utmp msg = do
    mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
    let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
    if not mesgy then return False else do
    text <- do
        t <- messageText msg
        return $ Text.unpack
            $ case stanzaFrom msg of
                Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n"
                Nothing -> crlf t <> "\r\n"
    writeFile (Text.unpack tty) text
    return True -- return True if a message was delivered

-- | Deliver the given message to all a user's PTYs.
writeAllPty :: ConsoleWriter -> Stanza -> IO Bool
writeAllPty cw msg = do
    -- TODO: filter only ptys owned by the destination user.
    us <- atomically $ readTVar (csUtmp cw)
    let ptys = Map.filterWithKey ispty us
        ispty k _ = "pts/" `Text.isPrefixOf` k
                    && Text.all isDigit (Text.drop 4 k)
    bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do
        deliverTerminalMessage cw ("/dev/" <> tty) utmp msg
    return $ or bs

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 :: IO Text
textHostName = fmap Text.pack BSD.getHostName

ujid :: UtmpRecord -> IO Text
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)
    forM_ 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)
    let r = resource u
    stanza <- makePresenceStanza
                            "jabber:client"
                            (Just jid)
                            (jstatus r tty tu)
    statusv <- atomically $ newTVar (Just stanza)
    flgs <- atomically $ newTVar 0
    let client = ClientState { clientResource = r
                             , clientUser     = utmpUser u
                             , clientProfile  = "."
                             , clientPid      = Nothing
                             , clientStatus   = statusv
                             , clientFlags    = flgs }
    atomically $ do
        modifyTVar (cwClients cw) $ Map.insert r client
        putTMVar (cwPresenceChan cw) (client,stanza)
    loop client 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 client 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')
            dup <- cloneStanza stanza
            atomically $ do
                writeTVar (clientStatus client) $ Just dup
                putTMVar (cwPresenceChan cw) (client,stanza)
            log $ status r tty' tu' <> " " <> jid
            loop client 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 client tty tu (Just u')
            dead = do
                jid <- maybe (return "") ujid u
                stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
                atomically $ do
                    modifyTVar (cwClients cw) $ Map.delete (clientResource client)
                    putTMVar (cwPresenceChan cw) (client,stanza)
                log $ "Offline   " <> jid