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
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, (SELECT COUNT(1) FROM sessions s where s.source_muc=sessions.source_muc AND s.target_muc=sessions.target_muc AND s.source_nick=sessions.source_nick) FROM sessions WHERE version < ? AND source_muc = ?")
(Config.dbVersion config, bareTxt source)
forM_ old $ \(muc, nick, source_nick, count) ->
let
Just target = XMPP.parseJID $ muc ++ s"/" ++ nick
Just source' = XMPP.parseJID $ bareTxt source ++ s"/" ++ source_nick
in
if count > (1::Int) then do
mkSession config XMPP.PresenceUnavailable (Just source') target
else do
sendPresence config ((XMPP.emptyPresence XMPP.PresenceUnavailable) {
XMPP.presenceFrom = Just source'
}) 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 Nothing Nothing Nothing) Nothing
sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Maybe 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
when (typ == XMPP.PresenceAvailable) $
mkSession config typ (Just from) target
XMPP.putStanza $ presence {
XMPP.presenceType = typ,
XMPP.presenceFrom = Just (proxyJid config from),
XMPP.presenceTo = Just target,
XMPP.presencePayloads = (
XML.Element (s"{https://ns.soprani.ca/cheogram-muc-bridge/ghost}ghost") [] []
) : 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 = maybe mempty (\t -> s"[" ++ t ++ s"]") tag
nickLength = fmap (subtract (T.length subscript) . 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 ()