summaryrefslogtreecommitdiff
path: root/examples/pwrite.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /examples/pwrite.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'examples/pwrite.hs')
-rw-r--r--examples/pwrite.hs105
1 files changed, 0 insertions, 105 deletions
diff --git a/examples/pwrite.hs b/examples/pwrite.hs
deleted file mode 100644
index bad6af06..00000000
--- a/examples/pwrite.hs
+++ /dev/null
@@ -1,105 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE OverloadedStrings #-}
4import System.Environment
5import System.Posix.Files ( getFileStatus, fileMode )
6import Data.Bits ( (.&.) )
7import Data.Text ( Text )
8import qualified Data.Text as Text
9import qualified Data.Text.IO as Text
10import Control.Applicative
11import Control.Monad
12import Data.Maybe
13import XMPPServer
14import 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.
19toBCP47 :: [Char] -> [Char]
20toBCP47 lang = map hyphen $ takeWhile (/='.') lang
21 where hyphen '_' = '-'
22 hyphen c = c
23
24
25#if MIN_VERSION_base(4,6,0)
26#else
27lookupEnv k = fmap (lookup k) getEnvironment
28#endif
29
30getPreferedLang :: IO Text
31getPreferedLang = 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
39cimatch :: Text -> Text -> Bool
40cimatch w t = Text.toLower w == Text.toLower t
41
42cimatches :: Text -> [Text] -> [Text]
43cimatches w ts = dropWhile (not . cimatch w) ts
44
45-- rfc4647 lookup of best match language tag
46lookupLang :: [Text] -> [Text] -> Maybe Text
47lookupLang (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
59lookupLang [] tags | "" `elem` tags = Just ""
60 | otherwise = listToMaybe $ tags
61
62
63messageText :: Stanza -> IO Text
64messageText 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
76crlf :: Text -> Text
77crlf t = Text.unlines $ map cr (Text.lines t)
78 where
79 cr t | Text.last t == '\r' = t
80 | otherwise = t <> "\r"
81
82deliverTerminalMessage ::
83 forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
84deliverTerminalMessage 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
97main = 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 ()