~singpolyma/cheogram-muc-bridge

ref: 380691995804ec9f33b8c51b09fb674c1854d53f cheogram-muc-bridge/Session.hs -rw-r--r-- 5.8 KiB
38069199Stephen Paul Weber isGhost helper 1 year, 4 months 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
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 FROM sessions WHERE version < ? AND source_muc = ?")
		(Config.dbVersion config, bareTxt source)
	forM_ old $ \(muc, nick, source_nick) ->
		let Just target = XMPP.parseJID $ muc  ++ s"/" ++ nick in
		sendPresence config ((XMPP.emptyPresence XMPP.PresenceUnavailable) {
			XMPP.presenceFrom = XMPP.parseJID $ bareTxt source ++ s"/" ++ source_nick
		}) 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)

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 (s"XMPP") Nothing Nothing) (s"XMPP")

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

sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Text -> XMPP.XMPP ()
sendPresenceToMUC config presence@XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just fromResource
	},
	XMPP.presenceType = typ,
	XMPP.presencePayloads = payloads
} targetMuc tag = do
	ghost <- isGhost config from
	when (not ghost) $ 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
	nickReplacement = maybe id replaceNotInClass (Config.nickChars targetMuc)
	target = maybeAddNick (Config.jid targetMuc) $ nickReplacement $
		(maybeTruncate nickLength fromNick) ++ subscript
	subscript = s"[" ++ tag ++ s"]"
	nickLength = fmap (subtract 2 . subtract (T.length tag) . 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 ()