path: root/Presence/ConsoleWriter.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
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
import System.Process ( rawSystem )
import System.Exit ( ExitCode(ExitSuccess) )
import System.Posix.Env     ( setEnv )
import System.Posix.Process ( forkProcess, exitImmediately )
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      ( monitorTTY )
import XMPPServer     ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
                      , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
import ControlMaybe   ( handleIO_ )
import ClientState

data ConsoleWriter = ConsoleWriter
    { cwPresenceChan :: TMVar (ClientState,Stanza)
    , csActiveTTY :: TVar Word8
    , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
    , cwClients :: TVar (Map Text ClientState)
    }

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 $ 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 <- 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

-- 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 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 w t = Text.toLower w == Text.toLower t
cimatches w ts = dropWhile (not . cimatch w) ts

-- rfc4647 lookup of best match language tag
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)
        choice = do
            k <- key
            lookup k m
    flip (maybe $ return "") choice $ \choice -> do
    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

writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
writeActiveTTY cw msg = do
    putStrLn $ "writeActiveTTY"
    (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 )
    flip (maybe $ 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 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]
        exitImmediately ExitSuccess
    return True

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
    -- TODO: deliver to active console
    return False -- return True if a message was delivered

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)
    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
                             , 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