diff --git a/IQManager.hs b/IQManager.hs new file mode 100644 index 0000000..21101ff --- /dev/null +++ b/IQManager.hs @@ -0,0 +1,75 @@ +module IQManager (iqManager) where + +import Prelude () +import BasicPrelude +import Control.Concurrent.STM ( + STM, TMVar, TVar, modifyTVar', newEmptyTMVar, newTVar, orElse, + readTVar, takeTMVar, tryPutTMVar, writeTVar + ) +import Control.Concurrent.STM.Delay (newDelay, waitDelay) +import UnexceptionalIO.Trans (Unexceptional) +import qualified Data.Map.Strict as Map +import qualified Network.Protocol.XMPP as XMPP +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID + +import Util + +type ResponseMap = Map.Map (Maybe Text) (TMVar XMPP.IQ) + +iqSendTimeoutMicroseconds :: Int +iqSendTimeoutMicroseconds = 5000000 + +iqDefaultID :: (Unexceptional m) => XMPP.IQ -> m XMPP.IQ +iqDefaultID iq@XMPP.IQ { XMPP.iqID = Just _ } = return iq +iqDefaultID iq = do + uuid <- fromIO_ UUID.nextRandom + return $ iq { + XMPP.iqID = Just $ UUID.toText uuid + } + +iqSenderUnexceptional :: (Unexceptional m) => + (XMPP.IQ -> m ()) + -> TVar ResponseMap + -> XMPP.IQ + -> m (STM (Maybe XMPP.IQ)) +iqSenderUnexceptional sender responseMapVar iq = do + iqToSend <- iqDefaultID iq + timeout <- fromIO_ $ newDelay iqSendTimeoutMicroseconds + iqResponseVar <- atomicUIO newEmptyTMVar + atomicUIO $ modifyTVar' responseMapVar $ + Map.insert (XMPP.iqID iqToSend) iqResponseVar + sender iqToSend + return ( + (waitDelay timeout *> pure Nothing) + `orElse` + fmap Just (takeTMVar iqResponseVar) + ) + +iqReceiver :: (Unexceptional m) => TVar ResponseMap -> XMPP.IQ -> m (Maybe XMPP.IQ) +iqReceiver responseMapVar receivedIQ + | XMPP.iqType receivedIQ `elem` [XMPP.IQResult, XMPP.IQError] = do + maybeIqResponseVar <- atomicUIO $ do + responseMap <- readTVar responseMapVar + let (maybeIqResponseVar, responseMap') = + Map.updateLookupWithKey + (const $ const Nothing) + (XMPP.iqID receivedIQ) responseMap + writeTVar responseMapVar $! responseMap' + return maybeIqResponseVar + case maybeIqResponseVar of + Just iqResponseVar -> do + atomicUIO $ tryPutTMVar iqResponseVar receivedIQ + return Nothing + Nothing -> return (Just receivedIQ) + | otherwise = return $ Just receivedIQ + +iqManager :: (Unexceptional m1, Unexceptional m2, Unexceptional m3) => + (XMPP.IQ -> m2 ()) -> + m1 (XMPP.IQ -> m2 (STM (Maybe XMPP.IQ)), XMPP.IQ -> m3 (Maybe XMPP.IQ)) +iqManager sender = do + responseMapVar <- atomicUIO $ newTVar Map.empty + return ( + iqSenderUnexceptional sender responseMapVar, + iqReceiver responseMapVar + ) diff --git a/Util.hs b/Util.hs index 70dacac..a787541 100644 --- a/Util.hs +++ b/Util.hs @@ -5,8 +5,12 @@ import BasicPrelude import Control.Applicative (many) import Control.Concurrent (ThreadId, forkFinally, myThreadId, throwTo) +import Control.Concurrent.STM (STM, atomically) import Data.Time.Clock (UTCTime) import Data.Time.Format (parseTimeM, defaultTimeLocale) +import Data.Void (absurd) +import UnexceptionalIO (Unexceptional) +import qualified UnexceptionalIO as UIO import qualified Control.Exception as Ex import qualified Data.Attoparsec.Text as Atto import qualified Data.Text as Text @@ -15,9 +19,18 @@ import qualified Network.Protocol.XMPP as XMPP import qualified Config +instance Unexceptional XMPP.XMPP where + lift = liftIO . UIO.lift + s :: (IsString s) => String -> s s = fromString +fromIO_ :: (Unexceptional m) => IO a -> m a +fromIO_ = fmap (either absurd id) . UIO.fromIO' (error . show) + +atomicUIO :: (Unexceptional m) => STM a -> m a +atomicUIO = fromIO_ . atomically + escapeJid :: Text -> Text escapeJid txt = mconcat result where diff --git a/cheogram-muc-bridge.cabal b/cheogram-muc-bridge.cabal index 9e1b4e3..deeab28 100644 --- a/cheogram-muc-bridge.cabal +++ b/cheogram-muc-bridge.cabal @@ -17,16 +17,21 @@ common defs basic-prelude >=0.7 && <0.8, bytestring >=0.10 && <0.11, containers >=0.5 && <0.6, - dhall >= 1.24 && < 2.0, + dhall >= 1.24 && <2.0, errors >=2.3 && <2.4, - network >= 2.6.3 && < 2.7, + network >= 2.6.3 && <2.7, network-protocol-xmpp >=0.4 && <0.5, sqlite-simple >= 0.4 && <0.5, + stm >= 2.4 && <3.0, + stm-delay >= 0.1 && < 0.2, text >=1.2 && <1.3, time >=1.5 && <2.0, + unexceptionalio >= 0.5 && <0.6, + unexceptionalio-trans >= 0.5 && <0.6, + uuid >= 1.3 && <2.0, xml-types >=0.3 && <0.4 executable gateway import: defs main-is: gateway.hs - other-modules: Router, Util, Config, ConfigFile, Session + other-modules: Router, Util, Config, ConfigFile, Session, IQManager diff --git a/gateway.hs b/gateway.hs index 2e4aebb..0e6c58a 100644 --- a/gateway.hs +++ b/gateway.hs @@ -5,6 +5,9 @@ import BasicPrelude import System.IO (stdout, stderr, hSetBuffering, BufferMode(LineBuffering)) import Control.Error (exceptT, justZ) +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (STM) +import qualified Database.SQLite.Simple as DB import qualified Data.Text as T import qualified Data.XML.Types as XML import qualified Network.Protocol.XMPP as XMPP @@ -13,6 +16,7 @@ import qualified Config import qualified Session import Router import Util +import IQManager hasMucCode :: Int -> XMPP.Presence -> Bool hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } = @@ -126,11 +130,47 @@ 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)) { + Session.mkSession config XMPP.PresenceAvailable Nothing target + XMPP.putStanza presence + where + Just target = XMPP.presenceTo presence + presence = (mucJoin muc (Config.nick config)) { XMPP.presenceFrom = Just $ Config.bridgeJid config } +pingSuccessError :: XML.Element -> [XML.Element] +pingSuccessError = uncurry (<|>) . (uncurry (<|>) . ( + XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavaliable") + &&& + XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") + ) &&& + XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found") + ) + +selfPings :: Config.Config -> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ))) -> XMPP.XMPP () +selfPings config sendIQ = forever $ do + liftIO $ threadDelay 60000000 + sessions <- liftIO $ DB.query_ (Config.db config) (s"SELECT source_muc, source_nick, target_muc, target_nick FROM sessions") + forM_ sessions $ \(sourceMuc, sourceNick, targetMuc, targetNick) -> void $ forkXMPP $ do + let Just target = XMPP.parseJID (targetMuc ++ s"/" ++ targetNick) + reply <- (atomicUIO =<<) $ sendIQ $ (XMPP.emptyIQ XMPP.IQGet) { + XMPP.iqFrom = sourceJid sourceMuc sourceNick, + XMPP.iqTo = Just target, + XMPP.iqPayload = Just $ XML.Element (s"{urn:xmpp:ping}ping") [] [] + } + if (XMPP.iqType <$> reply) == Just XMPP.IQResult then return () else + case pingSuccessError =<< XML.elementChildren =<< justZ (XMPP.iqPayload =<< reply) of + (_:_) -> return () + _ | sourceMuc == mempty -> joinFromBridge config target + _ -> + Session.sendPresence config ((mucJoin target targetNick) { + XMPP.presenceFrom = XMPP.parseJID (sourceMuc ++ s"/" ++ sourceNick) + }) target + where + sourceJid muc nick + | muc == mempty = Just $ Config.bridgeJid config + | otherwise = proxyJid config <$> XMPP.parseJID (muc ++ s"/" ++ nick) + main :: IO () main = do hSetBuffering stdout LineBuffering @@ -145,13 +185,17 @@ main = do exceptT print return $ runRoutedComponent server (Config.secret config) $ do + (sendIQ, iqReceiver) <- iqManager XMPP.putStanza forM_ (Config.mucs config) $ \bridge -> do joinFromBridge config (Config.muc1 bridge) joinFromBridge config (Config.muc2 bridge) + void $ forkXMPP $ selfPings config sendIQ return $ defaultRoutes { presenceRoute = handlePresence config, presenceErrorRoute = handlePresenceError config, messageGroupChatRoute = handleGroupChat config, messageRoute = handleMessage config, - iqRoute = handleIq config + iqRoute = \iq -> do + maybeIq <- iqReceiver iq + forM_ maybeIq $ handleIq config }