summaryrefslogtreecommitdiff
path: root/Presence/ConsoleWriter.hs
blob: c6e1871a0aeb4c102d0c783b144aaf1bc8b91aaa (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
{-# 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 System.IO.Error
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 DPut
import DebugTag
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
    muentry <- fmap Just (getUserEntryForName (Text.unpack $ utmpUser utmp))
                `catchIOError` \e -> do
                    dput XJabber $ "deliverGUIMessage(getUserEntryForName "++show (utmpUser utmp)++"): "++show e
                    return Nothing
    forM_ muentry $ \uentry -> do
        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 ()
    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