Store sessions in db
This commit is contained in:
parent
27ee019dec
commit
e1c417e2b1
|
|
@ -0,0 +1,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 ()
|
||||
18
Util.hs
18
Util.hs
|
|
@ -169,3 +169,21 @@ mkDiscoFeature var =
|
|||
|
||||
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
|
||||
(.:) = (.) . (.)
|
||||
|
||||
proxyJid :: Config.Config -> XMPP.JID -> XMPP.JID
|
||||
proxyJid config from = jid
|
||||
where
|
||||
Just jid = XMPP.parseJID $ escapeJid (XMPP.formatJID from)
|
||||
++ s"@" ++ XMPP.formatJID (Config.componentJid config) ++ s"/bridge"
|
||||
|
||||
mucJoin :: XMPP.JID -> Text -> XMPP.Presence
|
||||
mucJoin muc nick = (XMPP.emptyPresence XMPP.PresenceAvailable) {
|
||||
XMPP.presenceTo = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick,
|
||||
XMPP.presencePayloads = [mucJoinX]
|
||||
}
|
||||
|
||||
mucJoinX :: XML.Element
|
||||
mucJoinX = XML.Element (s"{http://jabber.org/protocol/muc}x") [] [
|
||||
XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/muc}history")
|
||||
[(s"maxchars", [XML.ContentText $ s"0"])] []
|
||||
]
|
||||
|
|
|
|||
|
|
@ -29,4 +29,4 @@ common defs
|
|||
executable gateway
|
||||
import: defs
|
||||
main-is: gateway.hs
|
||||
other-modules: Router, Util, Config, ConfigFile
|
||||
other-modules: Router, Util, Config, ConfigFile, Session
|
||||
|
|
|
|||
56
gateway.hs
56
gateway.hs
|
|
@ -10,21 +10,10 @@ import qualified Data.XML.Types as XML
|
|||
import qualified Network.Protocol.XMPP as XMPP
|
||||
|
||||
import qualified Config
|
||||
import qualified Session
|
||||
import Router
|
||||
import Util
|
||||
|
||||
mucJoin :: XMPP.JID -> Text -> XMPP.Presence
|
||||
mucJoin muc nick = (XMPP.emptyPresence XMPP.PresenceAvailable) {
|
||||
XMPP.presenceTo = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick,
|
||||
XMPP.presencePayloads = [mucJoinX]
|
||||
}
|
||||
|
||||
mucJoinX :: XML.Element
|
||||
mucJoinX = XML.Element (s"{http://jabber.org/protocol/muc}x") [] [
|
||||
XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/muc}history")
|
||||
[(s"maxchars", [XML.ContentText $ s"0"])] []
|
||||
]
|
||||
|
||||
hasMucCode :: Int -> XMPP.Presence -> Bool
|
||||
hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } =
|
||||
elem (tshow code) $
|
||||
|
|
@ -43,54 +32,42 @@ targets config from = mapMaybe (\bridge ->
|
|||
Nothing
|
||||
) (Config.mucs config)
|
||||
|
||||
proxyJid :: Config.Config -> XMPP.JID -> XMPP.JID
|
||||
proxyJid config from = jid
|
||||
where
|
||||
Just jid = XMPP.parseJID $ escapeJid (XMPP.formatJID from)
|
||||
++ s"@" ++ XMPP.formatJID (Config.componentJid config) ++ s"/bridge"
|
||||
|
||||
handlePresence :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
|
||||
handlePresence config presence@XMPP.Presence {
|
||||
XMPP.presenceFrom = Just from,
|
||||
XMPP.presenceTo = Just to,
|
||||
XMPP.presencePayloads = p
|
||||
XMPP.presenceTo = Just to
|
||||
}
|
||||
| bareTxt to /= bareTxt (Config.bridgeJid config) =
|
||||
-- This is to one of our ghosts, so just ignore it
|
||||
return ()
|
||||
| hasMucCode 110 presence = return () -- ignore self presence
|
||||
| Just resource <- XMPP.jidResource from,
|
||||
not (s"|" `T.isInfixOf` XMPP.strResource resource) = forM_ (targets config from) $ \target ->
|
||||
XMPP.putStanza $ presence {
|
||||
XMPP.presenceFrom = Just (proxyJid config from),
|
||||
XMPP.presenceTo = XMPP.parseJID $
|
||||
bareTxt target ++ s"/" ++ XMPP.strResource resource ++ s"|X",
|
||||
XMPP.presencePayloads = map (\payload ->
|
||||
case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
|
||||
[_] -> mucJoinX
|
||||
_ -> payload
|
||||
) p
|
||||
}
|
||||
not (s"[x]" `T.isInfixOf` XMPP.strResource resource) = forM_ (targets config from) $
|
||||
Session.sendPresence config presence
|
||||
handlePresence _ _ = return ()
|
||||
|
||||
handlePresenceError :: XMPP.Presence -> XMPP.XMPP ()
|
||||
handlePresenceError XMPP.Presence {
|
||||
handlePresenceError :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
|
||||
handlePresenceError config XMPP.Presence {
|
||||
XMPP.presenceFrom = Just from@XMPP.JID {
|
||||
XMPP.jidResource = Just resource
|
||||
},
|
||||
XMPP.presenceTo = Just to,
|
||||
XMPP.presenceTo = Just XMPP.JID { XMPP.jidNode = Just node },
|
||||
XMPP.presencePayloads = p
|
||||
} |
|
||||
Just originalSource <- XMPP.parseJID $ unescapeJid $ XMPP.strNode node,
|
||||
[err] <- XML.isNamed (s"{jabber:component:accept}error") =<< p,
|
||||
[_] <- XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}conflict") =<<
|
||||
XML.elementChildren err =
|
||||
XMPP.putStanza $ (mucJoin muc (nick ++ s"_")) {
|
||||
XMPP.presenceFrom = Just to
|
||||
}
|
||||
let
|
||||
toSend = (mucJoin muc (nick ++ s"_")) {
|
||||
XMPP.presenceFrom = Just originalSource
|
||||
}
|
||||
Just target = XMPP.presenceTo toSend
|
||||
in Session.sendPresence config toSend target
|
||||
where
|
||||
nick = XMPP.strResource resource
|
||||
Just muc = XMPP.parseJID $ bareTxt from
|
||||
handlePresenceError _ = return ()
|
||||
handlePresenceError _ _ = return ()
|
||||
|
||||
handleGroupChat :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
|
||||
handleGroupChat config message@XMPP.Message {
|
||||
|
|
@ -151,6 +128,7 @@ handleIq _ _ = return ()
|
|||
|
||||
joinFromBridge :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
|
||||
joinFromBridge config muc = do
|
||||
Session.mkSession config XMPP.PresenceAvailable Nothing muc
|
||||
XMPP.putStanza $ (mucJoin muc (Config.nick config)) {
|
||||
XMPP.presenceFrom = Just $ Config.bridgeJid config
|
||||
}
|
||||
|
|
@ -174,7 +152,7 @@ main = do
|
|||
joinFromBridge config (Config.muc2 bridge)
|
||||
return $ defaultRoutes {
|
||||
presenceRoute = handlePresence config,
|
||||
presenceErrorRoute = handlePresenceError,
|
||||
presenceErrorRoute = handlePresenceError config,
|
||||
messageGroupChatRoute = handleGroupChat config,
|
||||
messageRoute = handleMessage config,
|
||||
iqRoute = handleIq config
|
||||
|
|
|
|||
Loading…
Reference in New Issue