diff options
Diffstat (limited to 'pwrite.hs')
-rw-r--r-- | pwrite.hs | 105 |
1 files changed, 0 insertions, 105 deletions
diff --git a/pwrite.hs b/pwrite.hs deleted file mode 100644 index bad6af06..00000000 --- a/pwrite.hs +++ /dev/null | |||
@@ -1,105 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE RankNTypes #-} | ||
3 | {-# LANGUAGE OverloadedStrings #-} | ||
4 | import System.Environment | ||
5 | import System.Posix.Files ( getFileStatus, fileMode ) | ||
6 | import Data.Bits ( (.&.) ) | ||
7 | import Data.Text ( Text ) | ||
8 | import qualified Data.Text as Text | ||
9 | import qualified Data.Text.IO as Text | ||
10 | import Control.Applicative | ||
11 | import Control.Monad | ||
12 | import Data.Maybe | ||
13 | import XMPPServer | ||
14 | import Data.Monoid | ||
15 | |||
16 | -- Transforms a string of form language[_territory][.codeset][@modifier] | ||
17 | -- typically used in LC_ locale variables into the BCP 47 | ||
18 | -- language codes used in xml:lang attributes. | ||
19 | toBCP47 :: [Char] -> [Char] | ||
20 | toBCP47 lang = map hyphen $ takeWhile (/='.') lang | ||
21 | where hyphen '_' = '-' | ||
22 | hyphen c = c | ||
23 | |||
24 | |||
25 | #if MIN_VERSION_base(4,6,0) | ||
26 | #else | ||
27 | lookupEnv k = fmap (lookup k) getEnvironment | ||
28 | #endif | ||
29 | |||
30 | getPreferedLang :: IO Text | ||
31 | getPreferedLang = do | ||
32 | lang <- do | ||
33 | lc_all <- lookupEnv "LC_ALL" | ||
34 | lc_messages <- lookupEnv "LC_MESSAGES" | ||
35 | lang <- lookupEnv "LANG" | ||
36 | return $ lc_all `mplus` lc_messages `mplus` lang | ||
37 | return $ maybe "en" (Text.pack . toBCP47) lang | ||
38 | |||
39 | cimatch :: Text -> Text -> Bool | ||
40 | cimatch w t = Text.toLower w == Text.toLower t | ||
41 | |||
42 | cimatches :: Text -> [Text] -> [Text] | ||
43 | cimatches w ts = dropWhile (not . cimatch w) ts | ||
44 | |||
45 | -- rfc4647 lookup of best match language tag | ||
46 | lookupLang :: [Text] -> [Text] -> Maybe Text | ||
47 | lookupLang (w:ws) tags | ||
48 | | Text.null w = lookupLang ws tags | ||
49 | | otherwise = case cimatches w tags of | ||
50 | (t:_) -> Just t | ||
51 | [] -> lookupLang (reduce w:ws) tags | ||
52 | where | ||
53 | reduce w = Text.concat $ reverse nopriv | ||
54 | where | ||
55 | rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w | ||
56 | nopriv = dropWhile ispriv rparts | ||
57 | ispriv t = Text.length t == 2 && Text.head t == '-' | ||
58 | |||
59 | lookupLang [] tags | "" `elem` tags = Just "" | ||
60 | | otherwise = listToMaybe $ tags | ||
61 | |||
62 | |||
63 | messageText :: Stanza -> IO Text | ||
64 | messageText msg = do | ||
65 | pref <- getPreferedLang | ||
66 | let m = msgLangMap (stanzaType msg) | ||
67 | key = lookupLang [pref] (map fst m) | ||
68 | choice = do | ||
69 | k <- key | ||
70 | lookup k m | ||
71 | flip (maybe $ return "") choice $ \choice -> do | ||
72 | let subj = fmap ("Subject: " <>) $ msgSubject choice | ||
73 | ts = catMaybes [subj, msgBody choice] | ||
74 | return $ Text.intercalate "\n\n" ts | ||
75 | |||
76 | crlf :: Text -> Text | ||
77 | crlf t = Text.unlines $ map cr (Text.lines t) | ||
78 | where | ||
79 | cr t | Text.last t == '\r' = t | ||
80 | | otherwise = t <> "\r" | ||
81 | |||
82 | deliverTerminalMessage :: | ||
83 | forall t t1. t -> Text -> t1 -> Stanza -> IO Bool | ||
84 | deliverTerminalMessage cw tty utmp msg = do | ||
85 | mode <- fmap fileMode (getFileStatus $ Text.unpack tty) | ||
86 | let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w | ||
87 | if not mesgy then return False else do | ||
88 | text <- do | ||
89 | t <- messageText msg | ||
90 | return $ Text.unpack | ||
91 | $ case stanzaFrom msg of | ||
92 | Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n" | ||
93 | Nothing -> crlf t <> "\r\n" | ||
94 | writeFile (Text.unpack tty) text | ||
95 | return True -- return True if a message was delivered | ||
96 | |||
97 | main = do | ||
98 | args <- getArgs | ||
99 | let mas = (,) <$> listToMaybe args <*> listToMaybe (drop 1 args) | ||
100 | flip (maybe $ putStrLn "pwrite user tty") mas $ \(usr,tty) -> do | ||
101 | bod <- Text.getContents | ||
102 | stanza <- makeMessage "jabber:client" "nobody" (Text.pack usr) bod | ||
103 | b <- deliverTerminalMessage () (Text.pack tty) () stanza | ||
104 | when b $ putStrLn "delivered." | ||
105 | return () | ||