127 lines
4.5 KiB
Haskell
127 lines
4.5 KiB
Haskell
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
|
|
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 ()
|