From 006f17c1a1613e7e03bdd4025a0399cdb46cbd6d Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 4 Apr 2014 20:01:18 -0400 Subject: Type signatures and comments. --- Presence/ConsoleWriter.hs | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) (limited to 'Presence/ConsoleWriter.hs') 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 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module ConsoleWriter ( ConsoleWriter(cwPresenceChan) , newConsoleWriter @@ -43,19 +44,31 @@ 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) = @@ -93,6 +106,9 @@ onLogin cs start = \e -> do 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 ConsoleWriter newConsoleWriter = do chan <- atomically $ newEmptyTMVar @@ -137,6 +153,7 @@ newConsoleWriter = do -- 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 @@ -155,10 +172,14 @@ getPreferedLang = do 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 @@ -201,6 +222,11 @@ readEnvFile var file = fmap parse $ readFile file 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" @@ -218,6 +244,8 @@ writeActiveTTY cw msg = do 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 @@ -243,6 +271,8 @@ crlf t = Text.unlines $ map cr (Text.lines t) 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 @@ -256,6 +286,7 @@ deliverTerminalMessage cw tty utmp msg = do 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 us <- atomically $ readTVar (csUtmp cw) @@ -275,8 +306,10 @@ resource 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 -- cgit v1.2.3