~singpolyma/cheogram-muc-bridge

ref: b160817afb4bb631efdf461e50ab9037bf7a7ca4 cheogram-muc-bridge/gateway.hs -rw-r--r-- 6.2 KiB
b160817aStephen Paul Weber Actually works with biboumi now 1 year, 10 days ago
                                                                                
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
module Main (main) where

import Prelude ()
import BasicPrelude
import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Error                   (exceptT, justZ)
import qualified Dhall
import qualified Data.Text             as T
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP

import qualified Config
import Router
import Util

mucJoin :: XMPP.JID -> Text -> XMPP.Presence
mucJoin muc nick = (XMPP.emptyPresence XMPP.PresenceAvailable) {
		XMPP.presenceTo = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick,
		XMPP.presencePayloads = [mucJoinX]
	}

mucJoinX :: XML.Element
mucJoinX = XML.Element (s"{http://jabber.org/protocol/muc}x") [] [
		XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/muc}history")
			[(s"maxchars", [XML.ContentText $ s"0"])] []
	]

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

targets :: Config.Config -> XMPP.JID -> [XMPP.JID]
targets config from = mapMaybe (\bridge ->
		if bareTxt (Config.muc1 bridge) == bareTxt from then
			Just $ Config.muc2 bridge
		else if bareTxt (Config.muc2 bridge) == bareTxt from then
			Just $ Config.muc1 bridge
		else
			Nothing
	) (Config.mucs config)

proxyJid :: Config.Config -> XMPP.JID -> XMPP.JID
proxyJid config from = jid
	where
	Just jid = XMPP.parseJID $ escapeJid (XMPP.formatJID from)
		++ s"@" ++ XMPP.formatJID (Config.componentJid config) ++ s"/bridge"

handlePresence :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
handlePresence config presence@XMPP.Presence {
	XMPP.presenceFrom = Just from,
	XMPP.presenceTo = Just to,
	XMPP.presencePayloads = p
}
	| bareTxt to /= s"bridge@" ++ XMPP.formatJID (Config.componentJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| hasMucCode 110 presence = return () -- ignore self presence
	| Just resource <- XMPP.jidResource from,
	  not (s"|" `T.isInfixOf` XMPP.strResource resource) = forM_ (targets config from) $ \target ->
		XMPP.putStanza $ presence {
			XMPP.presenceFrom = Just (proxyJid config from),
			XMPP.presenceTo = XMPP.parseJID $
				bareTxt target ++ s"/" ++ XMPP.strResource resource ++ s"|X",
			XMPP.presencePayloads = map (\payload ->
				case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
					[_] -> mucJoinX
					_ -> payload
			) p
		}
handlePresence _ _ = return ()

handlePresenceError :: XMPP.Presence -> XMPP.XMPP ()
handlePresenceError XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just resource
	},
	XMPP.presenceTo = Just to,
	XMPP.presencePayloads = p
} |
	[err] <- XML.isNamed (s"{jabber:component:accept}error") =<< p,
	[_] <- XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}conflict") =<<
		XML.elementChildren err =
			XMPP.putStanza $ (mucJoin muc (nick ++ s"_")) {
				XMPP.presenceFrom = Just to
			}
	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 /= s"bridge@" ++ XMPP.formatJID (Config.componentJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| otherwise = forM_ (targets config from) $ \target ->
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config from),
			XMPP.messageTo = Just target
		}
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 ()

main :: IO ()
main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering

	config <- Dhall.input Dhall.auto =<< fmap head getArgs

	let server = XMPP.Server
		(Config.componentJid config)
		(Config.host $ Config.server config)
		(Config.port $ Config.server config)

	let Just bridgeJid = XMPP.parseJID $ s"bridge@" ++
		XMPP.formatJID (Config.componentJid config) ++ s"/bridge"

	exceptT print return $
		runRoutedComponent server (Config.secret config) $ do
			forM_ (Config.mucs config) $ \bridge -> do
				XMPP.putStanza $ (mucJoin (Config.muc1 bridge) (Config.nick config)) { XMPP.presenceFrom = Just bridgeJid }
				XMPP.putStanza $ (mucJoin (Config.muc2 bridge) (Config.nick config)) { XMPP.presenceFrom = Just bridgeJid }
			return $ defaultRoutes {
				presenceRoute = handlePresence config,
				presenceErrorRoute = handlePresenceError,
				messageGroupChatRoute = handleGroupChat config,
				messageRoute = handleMessage config,
				iqRoute = handleIq config
			}