blob: bad6af06d0569bfd831849cb3fdb808100ac8ef5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
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 ()
|
