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
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
module Main (main) where
import Prelude ()
import BasicPrelude
import System.IO
(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Error (exceptT, justZ)
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (STM)
import qualified Database.SQLite.Simple as DB
import qualified Data.Text as T
import qualified Data.XML.Types as XML
import qualified Network.Protocol.XMPP as XMPP
import qualified Config
import qualified Session
import Router
import Util
import IQManager
hasMucCode :: Int -> XMPP.Presence -> Bool
hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } =
elem (tshow code) $
maybeToList . XML.attributeText (s"code")
=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}status")
=<< XML.elementChildren
=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") =<< p
fullTargets :: Config.Config -> XMPP.JID -> [(Config.MUC, Maybe Text)]
fullTargets config from = concatMap (\bridge ->
case find ((bareTxt from ==) . bareTxt . Config.jid) bridge of
Just sourceMuc ->
map (\muc -> (muc, Config.tag sourceMuc)) $
filter ((bareTxt from /=) . bareTxt . Config.jid) bridge
Nothing -> []
) (Config.mucs config)
targets :: Config.Config -> XMPP.JID -> [XMPP.JID]
targets = map (Config.jid . fst) .: fullTargets
handlePresence :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
handlePresence config presence@XMPP.Presence {
XMPP.presenceFrom = Just from,
XMPP.presenceTo = Just to,
XMPP.presenceType = typ,
XMPP.presencePayloads = payloads
}
| typ == XMPP.PresenceAvailable,
hasMucCode 110 presence, -- done joining room
bareTxt to == bareTxt (Config.bridgeJid config) = do
liftIO $ DB.withTransaction (Config.db config) $ do
DB.execute (Config.db config)
(s"DELETE FROM sessions WHERE source_muc=? AND target_muc=?")
(Nothing :: Maybe Text, bareTxt from)
Session.mkSession config XMPP.PresenceAvailable Nothing from
Session.cleanOld config from
| typ == XMPP.PresenceAvailable,
hasMucCode 110 presence, -- done joining room
Just source <- (XMPP.parseJID . unescapeJid . XMPP.strNode) =<< XMPP.jidNode to =
liftIO $ DB.withTransaction (Config.db config) $ do
DB.execute (Config.db config)
(s"DELETE FROM sessions WHERE source_muc=? AND source_nick=? AND target_muc=?")
(
bareTxt source,
XMPP.strResource <$> XMPP.jidResource source,
bareTxt from
)
Session.mkSession config XMPP.PresenceAvailable (Just source) from
| typ == XMPP.PresenceUnavailable,
hasMucCode 110 presence, -- done leaving room
Just source <- (XMPP.parseJID . unescapeJid . XMPP.strNode) =<< XMPP.jidNode to =
Session.mkSession config typ (Just source) from
| bareTxt to /= bareTxt (Config.bridgeJid config) =
-- This is to one of our ghosts, so just ignore it
return ()
| (_:_) <- XML.isNamed (s"{https://ns.soprani.ca/cheogram-muc-bridge/ghost}ghost") =<< payloads =
-- This is from one of our ghosts, so just ignore it
return ()
| otherwise = forM_ (fullTargets config from) $
uncurry $ Session.sendPresenceToMUC config presence
handlePresence _ _ = return ()
handlePresenceError :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
handlePresenceError config XMPP.Presence {
XMPP.presenceFrom = Just from@XMPP.JID {
XMPP.jidResource = Just resource
},
XMPP.presenceTo = Just XMPP.JID { XMPP.jidNode = Just node },
XMPP.presencePayloads = p
} |
Just originalSource <- XMPP.parseJID $ unescapeJid $ XMPP.strNode node,
[err] <- XML.isNamed (s"{jabber:component:accept}error") =<< p,
[_] <- XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}conflict") =<<
XML.elementChildren err =
let
toSend = (mucJoin muc (nick ++ s"_")) {
XMPP.presenceFrom = Just originalSource
}
Just target = XMPP.presenceTo toSend
in Session.sendPresence config toSend target
where
nick = XMPP.strResource resource
Just muc = XMPP.parseJID $ bareTxt from
handlePresenceError _ _ = return ()
handleGroupChat :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
handleGroupChat config message@XMPP.Message {
XMPP.messageFrom = Just from,
XMPP.messageTo = Just to
}
| bareTxt to /= bareTxt (Config.bridgeJid config) =
-- This is to one of our ghosts, so just ignore it
return ()
| otherwise = forM_ (targets config from) $
Session.sendGroupChat config message
handleGroupChat _ _ = return ()
handleMessage :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
handleMessage config message@XMPP.Message {
XMPP.messageFrom = Just from@XMPP.JID { XMPP.jidNode = Just fromNode },
XMPP.messageTo = Just XMPP.JID { XMPP.jidNode = Just node }
}
| not $ null $ targets config from =
XMPP.putStanza $ message {
XMPP.messageFrom = Just (proxyJid config from),
XMPP.messageTo = target
}
| Just fakeFrom <- maybeFakeFrom =
XMPP.putStanza $ message {
XMPP.messageFrom = Just (proxyJid config fakeFrom),
XMPP.messageTo = target
}
where
target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
-- This is basically just for biboumi
-- If we get a direct message from a non-MUC source
-- check if there are any MUCs bridged to the given target
-- with a domain matching the domain of the from
-- and if so use the localpart (minus any %suffix) as a nick from that source
maybeFakeFrom = (XMPP.parseJID =<<) $
fmap ((++ s"/" ++ T.takeWhile (/='%') (XMPP.strNode fromNode)) . bareTxt) $
find (\source -> XMPP.jidDomain source == XMPP.jidDomain from) $
targets config =<< justZ target
handleMessage _ _ = return ()
handleIq :: Config.Config -> XMPP.IQ -> XMPP.XMPP ()
handleIq config iq@XMPP.IQ {
XMPP.iqFrom = Just from@XMPP.JID { XMPP.jidNode = Just _ },
XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Just node }
}
| not $ null $ targets config from =
XMPP.putStanza $ iq {
XMPP.iqFrom = Just (proxyJid config from),
XMPP.iqTo = target
}
where
target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
handleIq _ _ = return ()
joinFromBridge :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
joinFromBridge config muc = do
Session.mkSession config XMPP.PresenceAvailable Nothing target
XMPP.putStanza presence
where
Just target = XMPP.presenceTo presence
presence = (mucJoin muc (Config.nick config)) {
XMPP.presenceFrom = Just $ Config.bridgeJid config
}
pingSuccessError :: XML.Element -> [XML.Element]
pingSuccessError = uncurry (<|>) . (uncurry (<|>) . (
XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavaliable")
&&&
XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented")
) &&&
XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found")
)
selfPings :: Config.Config -> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ))) -> XMPP.XMPP ()
selfPings config sendIQ = forever $ do
liftIO $ threadDelay 60000000
sessions <- liftIO $ DB.query (Config.db config) (s"SELECT source_muc, source_nick, target_muc, target_nick FROM sessions WHERE version = ?") (DB.Only $ Config.dbVersion config)
forM_ sessions $ \(sourceMuc, sourceNick, targetMuc, targetNick) -> void $ forkXMPP $ do
let Just target = XMPP.parseJID (targetMuc ++ s"/" ++ targetNick)
reply <- (atomicUIO =<<) $ sendIQ $ (XMPP.emptyIQ XMPP.IQGet) {
XMPP.iqFrom = sourceJid sourceMuc sourceNick,
XMPP.iqTo = Just target,
XMPP.iqPayload = Just $ XML.Element (s"{urn:xmpp:ping}ping") [] []
}
if (XMPP.iqType <$> reply) == Just XMPP.IQResult then return () else
case pingSuccessError =<< XML.elementChildren =<< justZ (XMPP.iqPayload =<< reply) of
(_:_) -> return ()
_ | sourceMuc == mempty -> joinFromBridge config target
_ ->
Session.sendPresence config ((mucJoin target targetNick) {
XMPP.presenceFrom = XMPP.parseJID (sourceMuc ++ s"/" ++ sourceNick)
}) target
where
sourceJid muc nick
| muc == mempty = Just $ Config.bridgeJid config
| otherwise = proxyJid config <$> XMPP.parseJID (muc ++ s"/" ++ nick)
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
config <- Config.setup =<< fmap head getArgs
let server = XMPP.Server
(Config.componentJid config)
(Config.host $ Config.server config)
(Config.port $ Config.server config)
exceptT print return $
runRoutedComponent server (Config.secret config) $ do
(sendIQ, iqReceiver) <- iqManager XMPP.putStanza
forM_ (Config.mucs config) $ mapM_ $ \muc ->
joinFromBridge config (Config.jid muc)
void $ forkXMPP $ selfPings config sendIQ
return $ defaultRoutes {
presenceRoute = handlePresence config,
presenceErrorRoute = handlePresenceError config,
messageGroupChatRoute = handleGroupChat config,
messageRoute = handleMessage config,
iqRoute = \iq -> do
maybeIq <- iqReceiver iq
forM_ maybeIq $ handleIq config
}