4 files changed, 97 insertions(+), 40 deletions(-)

A Session.hs
M Util.hs
M cheogram-muc-bridge.cabal
M gateway.hs

@@ 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 ()

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

@@ 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

@@ 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