cheogram-muc-bridge/gateway.hs

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
			}