~singpolyma/cheogram-muc-bridge

e1c417e2b10c10053018ed474819f74b7598f798 — Stephen Paul Weber 1 year, 5 months ago 27ee019
Store sessions in db
4 files changed, 97 insertions(+), 40 deletions(-)

A Session.hs
M Util.hs
M cheogram-muc-bridge.cabal
M gateway.hs
A Session.hs => Session.hs +61 -0
@@ 0,0 1,61 @@
module Session where

import Prelude ()
import BasicPrelude
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

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 (?,?,?,?,?)")
			(sourceMuc, sourceNick, targetMuc, targetNick, Config.dbVersion config)
	where
	sourceMuc = bareTxt <$> source
	sourceNick = XMPP.strResource <$> (XMPP.jidResource =<< source)
	targetMuc = bareTxt target
	targetNick = 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@XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just fromResource
	},
	XMPP.presenceType = typ,
	XMPP.presencePayloads = payloads
} targetMuc = 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
	target = maybeAddNick targetMuc (fromNick ++ s"[x]")
	fromNick = XMPP.strResource fromResource
sendPresence _ _ _ = return ()

M Util.hs => Util.hs +18 -0
@@ 169,3 169,21 @@ mkDiscoFeature var =

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)

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"

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"])] []
	]

M cheogram-muc-bridge.cabal => cheogram-muc-bridge.cabal +1 -1
@@ 29,4 29,4 @@ common defs
executable gateway
  import:              defs
  main-is:             gateway.hs
  other-modules:       Router, Util, Config, ConfigFile
\ No newline at end of file
  other-modules:       Router, Util, Config, ConfigFile, Session

M gateway.hs => gateway.hs +17 -39
@@ 10,21 10,10 @@ import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP

import qualified Config
import qualified Session
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) $


@@ 43,54 32,42 @@ targets config from = mapMaybe (\bridge ->
			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
	XMPP.presenceTo = Just to
}
	| bareTxt to /= bareTxt (Config.bridgeJid 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
		}
	  not (s"[x]" `T.isInfixOf` XMPP.strResource resource) = forM_ (targets config from) $
		Session.sendPresence config presence
handlePresence _ _ = return ()

handlePresenceError :: XMPP.Presence -> XMPP.XMPP ()
handlePresenceError XMPP.Presence {
handlePresenceError :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
handlePresenceError config XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just resource
	},
	XMPP.presenceTo = Just to,
	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 =
			XMPP.putStanza $ (mucJoin muc (nick ++ s"_")) {
				XMPP.presenceFrom = Just to
			}
			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 ()
handlePresenceError _ _ = return ()

handleGroupChat :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
handleGroupChat config message@XMPP.Message {


@@ 151,6 128,7 @@ handleIq _ _ = return ()

joinFromBridge :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
joinFromBridge config muc = do
	Session.mkSession config XMPP.PresenceAvailable Nothing muc
	XMPP.putStanza $ (mucJoin muc (Config.nick config)) {
			XMPP.presenceFrom = Just $ Config.bridgeJid config
		}


@@ 174,7 152,7 @@ main = do
				joinFromBridge config (Config.muc2 bridge)
			return $ defaultRoutes {
				presenceRoute = handlePresence config,
				presenceErrorRoute = handlePresenceError,
				presenceErrorRoute = handlePresenceError config,
				messageGroupChatRoute = handleGroupChat config,
				messageRoute = handleMessage config,
				iqRoute = handleIq config