diff options
author | joe <joe@jerkface.net> | 2014-04-04 20:01:18 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2014-04-04 20:01:18 -0400 |
commit | 006f17c1a1613e7e03bdd4025a0399cdb46cbd6d (patch) | |
tree | bed6f65b5e29cc84cb5bcd7e149a674024d19389 /Presence/ConsoleWriter.hs | |
parent | aa5f289e226ce6e2c1b98996aa15db677583aba9 (diff) |
Type signatures and comments.
Diffstat (limited to 'Presence/ConsoleWriter.hs')
-rw-r--r-- | Presence/ConsoleWriter.hs | 33 |
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 #-} | ||
3 | module ConsoleWriter | 4 | module ConsoleWriter |
4 | ( ConsoleWriter(cwPresenceChan) | 5 | ( ConsoleWriter(cwPresenceChan) |
5 | , newConsoleWriter | 6 | , newConsoleWriter |
@@ -43,19 +44,31 @@ import ClientState | |||
43 | 44 | ||
44 | data ConsoleWriter = ConsoleWriter | 45 | data 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 | ||
55 | tshow :: forall a. Show a => a -> Text | ||
51 | tshow x = Text.pack . show $ x | 56 | tshow x = Text.pack . show $ x |
52 | 57 | ||
58 | retryWhen :: forall b. STM b -> (b -> Bool) -> STM b | ||
53 | retryWhen var pred = do | 59 | retryWhen 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 | ||
65 | onLogin :: | ||
66 | forall t. | ||
67 | ConsoleWriter | ||
68 | -> (STM (Word8, Maybe UtmpRecord) | ||
69 | -> TVar (Maybe UtmpRecord) -> IO ()) | ||
70 | -> t | ||
71 | -> IO () | ||
59 | onLogin cs start = \e -> do | 72 | onLogin 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. | ||
96 | newConsoleWriter :: IO ConsoleWriter | 112 | newConsoleWriter :: IO ConsoleWriter |
97 | newConsoleWriter = do | 113 | newConsoleWriter = 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. |
156 | toBCP47 :: [Char] -> [Char] | ||
140 | toBCP47 lang = map hyphen $ takeWhile (/='.') lang | 157 | toBCP47 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 | ||
175 | cimatch :: Text -> Text -> Bool | ||
158 | cimatch w t = Text.toLower w == Text.toLower t | 176 | cimatch w t = Text.toLower w == Text.toLower t |
177 | |||
178 | cimatches :: Text -> [Text] -> [Text] | ||
159 | cimatches w ts = dropWhile (not . cimatch w) ts | 179 | cimatches 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 |
182 | lookupLang :: [Text] -> [Text] -> Maybe Text | ||
162 | lookupLang (w:ws) tags | 183 | lookupLang (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. | ||
204 | writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool | 230 | writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool |
205 | writeActiveTTY cw msg = do | 231 | writeActiveTTY 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 | ||
247 | deliverGUIMessage :: | ||
248 | forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool | ||
221 | deliverGUIMessage cw tty utmp msg = do | 249 | deliverGUIMessage 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 | ||
274 | deliverTerminalMessage :: | ||
275 | forall t t1. t -> Text -> t1 -> Stanza -> IO Bool | ||
246 | deliverTerminalMessage cw tty utmp msg = do | 276 | deliverTerminalMessage 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. | ||
259 | writeAllPty :: ConsoleWriter -> Stanza -> IO Bool | 290 | writeAllPty :: ConsoleWriter -> Stanza -> IO Bool |
260 | writeAllPty cw msg = do | 291 | writeAllPty 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 | ||
309 | textHostName :: IO Text | ||
278 | textHostName = fmap Text.pack BSD.getHostName | 310 | textHostName = fmap Text.pack BSD.getHostName |
279 | 311 | ||
312 | ujid :: UtmpRecord -> IO Text | ||
280 | ujid u = do | 313 | ujid u = do |
281 | h <- textHostName | 314 | h <- textHostName |
282 | return $ utmpUser u <> "@" <> h <> "/" <> resource u | 315 | return $ utmpUser u <> "@" <> h <> "/" <> resource u |