pwrite utility/test application for writing messages to console.

1 files changed, 105 insertions, 0 deletions

diff --git a/pwrite.hs b/pwrite.hs
new file mode 100644
index 00000000..bad6af06
--- /dev/null
+++ b/pwrite.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+import System.Environment
+import System.Posix.Files ( getFileStatus, fileMode )
+import Data.Bits          ( (.&.) )
+import Data.Text          ( Text )
+import qualified Data.Text    as Text
+import qualified Data.Text.IO as Text
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+import XMPPServer
+import Data.Monoid
+
+-- 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)
+        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
+
+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
+
+main = do
+    args <- getArgs
+    let mas = (,) <$> listToMaybe args <*> listToMaybe (drop 1 args)
+    flip (maybe $ putStrLn "pwrite user tty") mas $ \(usr,tty) -> do
+    bod <- Text.getContents
+    stanza <- makeMessage "jabber:client" "nobody" (Text.pack usr) bod
+    b <- deliverTerminalMessage () (Text.pack tty) () stanza
+    when b $ putStrLn "delivered."
+    return ()