summaryrefslogtreecommitdiff
path: root/Presence/ConsoleWriter.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-04-04 20:01:18 -0400
committerjoe <joe@jerkface.net>2014-04-04 20:01:18 -0400
commit006f17c1a1613e7e03bdd4025a0399cdb46cbd6d (patch)
treebed6f65b5e29cc84cb5bcd7e149a674024d19389 /Presence/ConsoleWriter.hs
parentaa5f289e226ce6e2c1b98996aa15db677583aba9 (diff)
Type signatures and comments.
Diffstat (limited to 'Presence/ConsoleWriter.hs')
-rw-r--r--Presence/ConsoleWriter.hs33
1 files changed, 33 insertions, 0 deletions
diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index 2a77394f..5ed4f1df 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -1,5 +1,6 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
3module ConsoleWriter 4module ConsoleWriter
4 ( ConsoleWriter(cwPresenceChan) 5 ( ConsoleWriter(cwPresenceChan)
5 , newConsoleWriter 6 , newConsoleWriter
@@ -43,19 +44,31 @@ import ClientState
43 44
44data ConsoleWriter = ConsoleWriter 45data ConsoleWriter = ConsoleWriter
45 { cwPresenceChan :: TMVar (ClientState,Stanza) 46 { cwPresenceChan :: TMVar (ClientState,Stanza)
47 -- ^ tty switches and logins are announced on this mvar
46 , csActiveTTY :: TVar Word8 48 , csActiveTTY :: TVar Word8
47 , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord))) 49 , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
48 , cwClients :: TVar (Map Text ClientState) 50 , cwClients :: TVar (Map Text ClientState)
51 -- ^ This 'TVar' holds a map from resource id (tty name)
52 -- to ClientState for all active TTYs and PTYs.
49 } 53 }
50 54
55tshow :: forall a. Show a => a -> Text
51tshow x = Text.pack . show $ x 56tshow x = Text.pack . show $ x
52 57
58retryWhen :: forall b. STM b -> (b -> Bool) -> STM b
53retryWhen var pred = do 59retryWhen var pred = do
54 value <- var 60 value <- var
55 if pred value then retry 61 if pred value then retry
56 else return value 62 else return value
57 63
58 64
65onLogin ::
66 forall t.
67 ConsoleWriter
68 -> (STM (Word8, Maybe UtmpRecord)
69 -> TVar (Maybe UtmpRecord) -> IO ())
70 -> t
71 -> IO ()
59onLogin cs start = \e -> do 72onLogin cs start = \e -> do
60 us <- UTmp.users2 73 us <- UTmp.users2
61 let (m,cruft) = 74 let (m,cruft) =
@@ -93,6 +106,9 @@ onLogin cs start = \e -> do
93 forkIO . start getActive 106 forkIO . start getActive
94 -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show 107 -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show
95 108
109-- | Sets up threads to monitor tty switches and logins that are
110-- written to the system utmp file and returns a 'ConsoleWriter'
111-- object for interacting with that information.
96newConsoleWriter :: IO ConsoleWriter 112newConsoleWriter :: IO ConsoleWriter
97newConsoleWriter = do 113newConsoleWriter = do
98 chan <- atomically $ newEmptyTMVar 114 chan <- atomically $ newEmptyTMVar
@@ -137,6 +153,7 @@ newConsoleWriter = do
137-- Transforms a string of form language[_territory][.codeset][@modifier] 153-- Transforms a string of form language[_territory][.codeset][@modifier]
138-- typically used in LC_ locale variables into the BCP 47 154-- typically used in LC_ locale variables into the BCP 47
139-- language codes used in xml:lang attributes. 155-- language codes used in xml:lang attributes.
156toBCP47 :: [Char] -> [Char]
140toBCP47 lang = map hyphen $ takeWhile (/='.') lang 157toBCP47 lang = map hyphen $ takeWhile (/='.') lang
141 where hyphen '_' = '-' 158 where hyphen '_' = '-'
142 hyphen c = c 159 hyphen c = c
@@ -155,10 +172,14 @@ getPreferedLang = do
155 return $ lc_all `mplus` lc_messages `mplus` lang 172 return $ lc_all `mplus` lc_messages `mplus` lang
156 return $ maybe "en" (Text.pack . toBCP47) lang 173 return $ maybe "en" (Text.pack . toBCP47) lang
157 174
175cimatch :: Text -> Text -> Bool
158cimatch w t = Text.toLower w == Text.toLower t 176cimatch w t = Text.toLower w == Text.toLower t
177
178cimatches :: Text -> [Text] -> [Text]
159cimatches w ts = dropWhile (not . cimatch w) ts 179cimatches w ts = dropWhile (not . cimatch w) ts
160 180
161-- rfc4647 lookup of best match language tag 181-- rfc4647 lookup of best match language tag
182lookupLang :: [Text] -> [Text] -> Maybe Text
162lookupLang (w:ws) tags 183lookupLang (w:ws) tags
163 | Text.null w = lookupLang ws tags 184 | Text.null w = lookupLang ws tags
164 | otherwise = case cimatches w tags of 185 | otherwise = case cimatches w tags of
@@ -201,6 +222,11 @@ readEnvFile var file = fmap parse $ readFile file
201 where 222 where
202 gs = groupBy (\_ x -> pred x) xs 223 gs = groupBy (\_ x -> pred x) xs
203 224
225-- | Delivers an XMPP message stanza to the currently active
226-- tty. If that is a linux console, it will write to it similar
227-- to the manner of the BSD write command. If that is an X11
228-- display, it will attempt to notify the user via a libnotify
229-- interface.
204writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool 230writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
205writeActiveTTY cw msg = do 231writeActiveTTY cw msg = do
206 putStrLn $ "writeActiveTTY" 232 putStrLn $ "writeActiveTTY"
@@ -218,6 +244,8 @@ writeActiveTTY cw msg = do
218 Just True -> deliverGUIMessage cw tty utmp msg 244 Just True -> deliverGUIMessage cw tty utmp msg
219 _ -> deliverTerminalMessage cw tty utmp msg 245 _ -> deliverTerminalMessage cw tty utmp msg
220 246
247deliverGUIMessage ::
248 forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool
221deliverGUIMessage cw tty utmp msg = do 249deliverGUIMessage cw tty utmp msg = do
222 text <- do 250 text <- do
223 t <- messageText msg 251 t <- messageText msg
@@ -243,6 +271,8 @@ crlf t = Text.unlines $ map cr (Text.lines t)
243 cr t | Text.last t == '\r' = t 271 cr t | Text.last t == '\r' = t
244 | otherwise = t <> "\r" 272 | otherwise = t <> "\r"
245 273
274deliverTerminalMessage ::
275 forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
246deliverTerminalMessage cw tty utmp msg = do 276deliverTerminalMessage cw tty utmp msg = do
247 mode <- fmap fileMode (getFileStatus $ Text.unpack tty) 277 mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
248 let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w 278 let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
@@ -256,6 +286,7 @@ deliverTerminalMessage cw tty utmp msg = do
256 writeFile (Text.unpack tty) text 286 writeFile (Text.unpack tty) text
257 return True -- return True if a message was delivered 287 return True -- return True if a message was delivered
258 288
289-- | Deliver the given message to all a user's PTYs.
259writeAllPty :: ConsoleWriter -> Stanza -> IO Bool 290writeAllPty :: ConsoleWriter -> Stanza -> IO Bool
260writeAllPty cw msg = do 291writeAllPty cw msg = do
261 us <- atomically $ readTVar (csUtmp cw) 292 us <- atomically $ readTVar (csUtmp cw)
@@ -275,8 +306,10 @@ resource u =
275 where 306 where
276 escapeR s = s 307 escapeR s = s
277 308
309textHostName :: IO Text
278textHostName = fmap Text.pack BSD.getHostName 310textHostName = fmap Text.pack BSD.getHostName
279 311
312ujid :: UtmpRecord -> IO Text
280ujid u = do 313ujid u = do
281 h <- textHostName 314 h <- textHostName
282 return $ utmpUser u <> "@" <> h <> "/" <> resource u 315 return $ utmpUser u <> "@" <> h <> "/" <> resource u