2021-06-26 03:06:23 +00:00
module Session where
import Prelude ( )
import BasicPrelude
2021-06-29 01:39:41 +00:00
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
2021-06-26 03:06:23 +00:00
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
2021-06-29 02:32:11 +00:00
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
2021-06-26 03:06:23 +00:00
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 )
2021-06-29 02:32:11 +00:00
( 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
)
2021-06-26 03:06:23 +00:00
where
2021-06-29 02:32:11 +00:00
sourceMuc = fromMaybe mempty ( bareTxt <$> source )
sourceNick = fromMaybe mempty ( XMPP . strResource <$> ( XMPP . jidResource =<< source ) )
2021-06-26 03:06:23 +00:00
targetMuc = bareTxt target
2021-06-29 02:32:11 +00:00
targetNick = fromMaybe mempty ( XMPP . strResource <$> XMPP . jidResource target )
2021-06-26 03:06:23 +00:00
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 ()
2021-06-29 01:39:41 +00:00
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 )
2021-06-29 02:32:11 +00:00
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 )
2021-06-29 01:39:41 +00:00
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 $
2021-06-29 02:32:11 +00:00
nickSwap ( mconcat ( XML . elementText body ) )
2021-06-29 01:39:41 +00:00
] }
_ -> el
) payloads
}
sendGroupChat _ _ _ = return ()