~singpolyma/cheogram-muc-bridge

ref: 3d6657e165a247cf1807496f1c44912674a61f5c cheogram-muc-bridge/Session.hs -rw-r--r-- 4.7 KiB
3d6657e1Stephen Paul Weber Detect ghost presence from DB instead of by looking for tag in nick 1 year, 1 month 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
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@XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just fromResource
	},
	XMPP.presenceType = typ,
	XMPP.presencePayloads = payloads
} targetMuc = do
	ghost <- liftIO $ DB.query (Config.db config)
		(s"SELECT COUNT(1) FROM sessions WHERE target_muc = ? AND target_nick = ? LIMIT 1")
		(bareTxt from, fromNick)
	when (ghost == [DB.Only (0::Int)]) $ 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 ()

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"

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