~singpolyma/cheogram-muc-bridge

cheogram-muc-bridge/Session.hs -rw-r--r-- 6.4 KiB
caf03566Stephen Paul Weber Use non-extra-payload algorthm for rooms that don't support it 2 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
module Session where

import Prelude ()
import BasicPrelude
import Control.Applicative (many)
import qualified Data.Attoparsec.Text  as Atto hiding (Parser)
import qualified Data.Attoparsec.Internal.Types as Atto
import qualified Data.Text             as T
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

cleanOld :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
cleanOld config source = do
	old <- liftIO $ DB.query (Config.db config)
		(s"SELECT target_muc, target_nick, source_nick, (SELECT COUNT(1) FROM sessions s where s.source_muc=sessions.source_muc AND s.target_muc=sessions.target_muc AND s.source_nick=sessions.source_nick) FROM sessions WHERE version < ? AND source_muc = ?")
		(Config.dbVersion config, bareTxt source)
	forM_ old $ \(muc, nick, source_nick, count) ->
		let
			Just target = XMPP.parseJID $ muc  ++ s"/" ++ nick
			Just source' = XMPP.parseJID $ bareTxt source ++ s"/" ++ source_nick
		in
		if count > (1::Int) then do
			mkSession config XMPP.PresenceUnavailable (Just source') target
		else do
			sendPresence config ((XMPP.emptyPresence XMPP.PresenceUnavailable) {
				XMPP.presenceFrom = Just source'
			}) target

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 (?,?,?,?,?) ON CONFLICT(source_muc,source_nick,target_muc,target_nick) DO UPDATE SET version=?")
			(
				sourceMuc, sourceNick, targetMuc, targetNick,
				Config.dbVersion config, Config.dbVersion config
			)
	where
	sourceMuc = fromMaybe mempty (bareTxt <$> source)
	sourceNick = fromMaybe mempty (XMPP.strResource <$> (XMPP.jidResource =<< source))
	targetMuc = bareTxt target
	targetNick = fromMaybe mempty (XMPP.strResource <$> XMPP.jidResource target)


isGhost :: (MonadIO m) => Config.Config -> XMPP.JID -> m Bool
isGhost config from = do
	ghost <- liftIO $ DB.query (Config.db config)
		(s"SELECT COUNT(1) FROM sessions WHERE target_muc = ? AND target_nick = ? LIMIT 1")
		(bareTxt from, nick)
	return (ghost /= [DB.Only (0::Int)])
	where
	nick = fromMaybe mempty $ XMPP.strResource <$> XMPP.jidResource from

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 targetMuc =
	sendPresenceToMUC config presence
		(Config.MUC targetMuc Nothing Nothing Nothing False)
		(Config.MUC (error "unknown sourceMuc") Nothing Nothing Nothing True)

sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Config.MUC -> XMPP.XMPP ()
sendPresenceToMUC config presence@XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just fromResource
	},
	XMPP.presenceType = typ,
	XMPP.presencePayloads = payloads
} targetMuc sourceMuc = do
	ghost <- if (Config.extraPresencePayloads sourceMuc) then
		return False
	else
		isGhost config from

	when (not ghost) $ do
		when (typ == XMPP.PresenceAvailable) $
			mkSession config typ (Just from) target

		XMPP.putStanza $ presence {
				XMPP.presenceType = typ,
				XMPP.presenceFrom = Just (proxyJid config from),
				XMPP.presenceTo = Just target,
				XMPP.presencePayloads = (
					XML.Element (s"{https://ns.soprani.ca/cheogram-muc-bridge/ghost}ghost") [] []
				) : map (\payload ->
					case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
						[_] -> mucJoinX
						_ -> payload
				) payloads
			}
	where
	nickReplacement = maybe id replaceNotInClass (Config.nickChars targetMuc)
	target = maybeAddNick (Config.jid targetMuc) $ nickReplacement $
		maybeTruncate nickLength fromNick ++ subscript
	subscript = maybe mempty (\t -> s"[" ++ t ++ s"]") (Config.tag sourceMuc)
	nickLength = fmap (subtract (T.length subscript) . fromIntegral) $
		Config.nickLength targetMuc
	fromNick = XMPP.strResource fromResource
sendPresenceToMUC _ _ _ _ = return ()

startOfInput :: Atto.Parser t ()
startOfInput = Atto.Parser $ \t pos more lose suc ->
	if pos == 0 then
		suc t pos more ()
	else
		lose t pos more [] "startOfInput"

maybeTruncate :: Maybe Int -> Text -> Text
maybeTruncate Nothing t = t
maybeTruncate (Just l) t = T.take l t

replaceNotInClass :: String -> Text -> Text
replaceNotInClass klass txt = mconcat result
	where
	Right result = Atto.parseOnly (many (
			Atto.takeWhile1 (Atto.inClass klass) <|>
			(Atto.takeWhile1 (Atto.notInClass klass) *> pure (s"_"))
		) <* Atto.endOfInput) txt

replaceWords :: [(Text, Text)] -> Text -> Text
replaceWords replacements txt = mconcat result
	where
	wordClass = "A-Za-z0-9_"
	boundary =
		(startOfInput *> pure mempty) <|>
		(Atto.endOfInput *> pure mempty) <|>
		(T.singleton <$> Atto.satisfy (Atto.notInClass wordClass))
	replacement word newWord = mconcat <$> (
		(:) <$> boundary <*> (
			(:) <$> (Atto.string word *> pure newWord) <*>
			((:) <$> boundary <*> pure [])
		))
	Right result = Atto.parseOnly (many (
			foldr (<|>) (T.singleton <$> Atto.anyChar) (uncurry replacement <$> replacements)
		) <* Atto.endOfInput) txt

sendGroupChat :: Config.Config -> XMPP.Message -> XMPP.JID -> XMPP.XMPP ()
sendGroupChat config message@XMPP.Message {
	XMPP.messageFrom = Just from,
	XMPP.messagePayloads = payloads
} target = do
		nickSwaps1 <- liftIO $ DB.query (Config.db config) (s"SELECT target_nick, source_nick FROM sessions WHERE source_muc=?") (DB.Only $ bareTxt target)
		nickSwaps2 <- liftIO $ DB.query (Config.db config) (s"SELECT source_nick, target_nick FROM sessions WHERE target_muc=? AND source_muc <> ''") (DB.Only $ bareTxt target)
		let nickSwap = replaceWords (nickSwaps1 ++ nickSwaps2)
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config from),
			XMPP.messageTo = Just target,
			XMPP.messagePayloads = map (\el ->
				case XML.isNamed (s"{jabber:component:accept}body") el of
					[body] ->
						body { XML.elementNodes = [
							XML.NodeContent $ XML.ContentText $
								nickSwap (mconcat (XML.elementText body))
						]}
					_ -> el
			) payloads
		}
sendGroupChat _ _ _ = return ()