~singpolyma/cheogram-muc-bridge

ref: e1c417e2b10c10053018ed474819f74b7598f798 cheogram-muc-bridge/Session.hs -rw-r--r-- 1.9 KiB
e1c417e2Stephen Paul Weber Store sessions in db 1 year, 10 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
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 ()