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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
module Session where
import Prelude ()
import BasicPrelude
import Control.Applicative (many)
import qualified Data.Attoparsec.Text as Atto hiding (Parser)
import qualified Data.Attoparsec.Internal.Types as Atto
import qualified Data.Text as T
import qualified Database.SQLite.Simple as DB
import qualified Data.XML.Types as XML
import qualified Network.Protocol.XMPP as XMPP
import qualified Config
import Util
cleanOld :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
cleanOld config source = do
old <- liftIO $ DB.query (Config.db config)
(s"SELECT target_muc, target_nick, source_nick FROM sessions WHERE version < ? AND source_muc = ?")
(Config.dbVersion config, bareTxt source)
forM_ old $ \(muc, nick, source_nick) ->
let Just target = XMPP.parseJID $ muc ++ s"/" ++ nick in
sendPresence config ((XMPP.emptyPresence XMPP.PresenceUnavailable) {
XMPP.presenceFrom = XMPP.parseJID $ bareTxt source ++ s"/" ++ source_nick
}) target
mkSession :: (MonadIO m) =>
Config.Config
-> XMPP.PresenceType
-> Maybe XMPP.JID
-> XMPP.JID
-> m ()
mkSession config typ source target
| typ == XMPP.PresenceUnavailable =
liftIO $ DB.execute (Config.db config)
(s"DELETE FROM sessions WHERE source_muc=? AND source_nick=? AND target_muc=? AND target_nick=?")
(sourceMuc, sourceNick, targetMuc, targetNick)
| otherwise =
liftIO $ DB.execute (Config.db config)
(s"INSERT INTO sessions VALUES (?,?,?,?,?) ON CONFLICT(source_muc,source_nick,target_muc,target_nick) DO UPDATE SET version=?")
(
sourceMuc, sourceNick, targetMuc, targetNick,
Config.dbVersion config, Config.dbVersion config
)
where
sourceMuc = fromMaybe mempty (bareTxt <$> source)
sourceNick = fromMaybe mempty (XMPP.strResource <$> (XMPP.jidResource =<< source))
targetMuc = bareTxt target
targetNick = fromMaybe mempty (XMPP.strResource <$> XMPP.jidResource target)
maybeAddNick :: XMPP.JID -> Text -> XMPP.JID
maybeAddNick jid@XMPP.JID { XMPP.jidResource = Just _ } _ = jid
maybeAddNick muc nick = jid
where
Just jid = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick
sendPresence :: Config.Config -> XMPP.Presence -> XMPP.JID -> XMPP.XMPP ()
sendPresence config presence targetMuc =
sendPresenceToMUC config presence
(Config.MUC targetMuc (s"XMPP") Nothing Nothing) (s"XMPP")
isGhost :: (MonadIO m) => Config.Config -> XMPP.JID -> m Bool
isGhost config from = do
ghost <- liftIO $ DB.query (Config.db config)
(s"SELECT COUNT(1) FROM sessions WHERE target_muc = ? AND target_nick = ? LIMIT 1")
(bareTxt from, nick)
return (ghost /= [DB.Only (0::Int)])
where
nick = fromMaybe mempty $ XMPP.strResource <$> XMPP.jidResource from
sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Text -> XMPP.XMPP ()
sendPresenceToMUC config presence@XMPP.Presence {
XMPP.presenceFrom = Just from@XMPP.JID {
XMPP.jidResource = Just fromResource
},
XMPP.presenceType = typ,
XMPP.presencePayloads = payloads
} targetMuc tag = do
ghost <- isGhost config from
when (not ghost) $ do
mkSession config typ (Just from) target
XMPP.putStanza $ presence {
XMPP.presenceFrom = Just (proxyJid config from),
XMPP.presenceTo = Just target,
XMPP.presencePayloads = map (\payload ->
case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
[_] -> mucJoinX
_ -> payload
) payloads
}
where
nickReplacement = maybe id replaceNotInClass (Config.nickChars targetMuc)
target = maybeAddNick (Config.jid targetMuc) $ nickReplacement $
(maybeTruncate nickLength fromNick) ++ subscript
subscript = s"[" ++ tag ++ s"]"
nickLength = fmap (subtract 2 . subtract (T.length tag) . fromIntegral) $
Config.nickLength targetMuc
fromNick = XMPP.strResource fromResource
sendPresenceToMUC _ _ _ _ = return ()
startOfInput :: Atto.Parser t ()
startOfInput = Atto.Parser $ \t pos more lose suc ->
if pos == 0 then
suc t pos more ()
else
lose t pos more [] "startOfInput"
maybeTruncate :: Maybe Int -> Text -> Text
maybeTruncate Nothing t = t
maybeTruncate (Just l) t = T.take l t
replaceNotInClass :: String -> Text -> Text
replaceNotInClass klass txt = mconcat result
where
Right result = Atto.parseOnly (many (
Atto.takeWhile1 (Atto.inClass klass) <|>
(Atto.takeWhile1 (Atto.notInClass klass) *> pure (s"_"))
) <* Atto.endOfInput) txt
replaceWords :: [(Text, Text)] -> Text -> Text
replaceWords replacements txt = mconcat result
where
wordClass = "A-Za-z0-9_"
boundary =
(startOfInput *> pure mempty) <|>
(Atto.endOfInput *> pure mempty) <|>
(T.singleton <$> Atto.satisfy (Atto.notInClass wordClass))
replacement word newWord = mconcat <$> (
(:) <$> boundary <*> (
(:) <$> (Atto.string word *> pure newWord) <*>
((:) <$> boundary <*> pure [])
))
Right result = Atto.parseOnly (many (
foldr (<|>) (T.singleton <$> Atto.anyChar) (uncurry replacement <$> replacements)
) <* Atto.endOfInput) txt
sendGroupChat :: Config.Config -> XMPP.Message -> XMPP.JID -> XMPP.XMPP ()
sendGroupChat config message@XMPP.Message {
XMPP.messageFrom = Just from,
XMPP.messagePayloads = payloads
} target = do
nickSwaps1 <- liftIO $ DB.query (Config.db config) (s"SELECT target_nick, source_nick FROM sessions WHERE source_muc=?") (DB.Only $ bareTxt target)
nickSwaps2 <- liftIO $ DB.query (Config.db config) (s"SELECT source_nick, target_nick FROM sessions WHERE target_muc=? AND source_muc <> ''") (DB.Only $ bareTxt target)
let nickSwap = replaceWords (nickSwaps1 ++ nickSwaps2)
XMPP.putStanza $ message {
XMPP.messageFrom = Just (proxyJid config from),
XMPP.messageTo = Just target,
XMPP.messagePayloads = map (\el ->
case XML.isNamed (s"{jabber:component:accept}body") el of
[body] ->
body { XML.elementNodes = [
XML.NodeContent $ XML.ContentText $
nickSwap (mconcat (XML.elementText body))
]}
_ -> el
) payloads
}
sendGroupChat _ _ _ = return ()