From c4ef096cce58cc13977675b0883c59cdcca813cf Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Thu, 20 Aug 2020 19:38:54 -0500 Subject: [PATCH] Fallback to direct initiate when no Jingle Message Initation support Check for a message initiation supporting resource, if none then send to the most available resource. TODO: Should only send to most available resource that supports jingle rtp audio. --- RedisURL.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++++ cheogram-sip.cabal | 8 +++- gateway.hs | 45 ++++++++++++++++------ 3 files changed, 135 insertions(+), 13 deletions(-) create mode 100644 RedisURL.hs diff --git a/RedisURL.hs b/RedisURL.hs new file mode 100644 index 0000000..8cb3eb2 --- /dev/null +++ b/RedisURL.hs @@ -0,0 +1,95 @@ +{- +Copyright (c)2011, Falko Peters +Some modifications by Stephen Paul Weber + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Falko Peters nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} +module RedisURL (parseConnectInfo) where + +import Prelude () +import BasicPrelude +import Control.Error.Util (note) +import Control.Monad (guard) +import Data.Monoid ((<>)) +import Database.Redis (ConnectInfo(..), defaultConnectInfo, PortID(..)) +import Network.HTTP.Base +import Network.HTTP.Types (parseSimpleQuery) +import Network.URI (URI, parseURI, uriPath, uriScheme, uriQuery) +import Text.Read (readMaybe) + +import qualified Data.ByteString.Char8 as C8 + +parseConnectInfo :: String -> Either String ConnectInfo +parseConnectInfo url = do + uri <- note "Invalid URI" $ parseURI url + case uriScheme uri of + "redis:" -> parseRedisScheme uri + "unix:" -> parseUnixScheme uri + _ -> Left "Invalid scheme" + +parseUnixScheme :: URI -> Either String ConnectInfo +parseUnixScheme uri = + return defaultConnectInfo + { connectHost = "" + , connectPort = UnixSocket path + , connectAuth = C8.pack <$> (password =<< uriAuth) + , connectDatabase = db + } + where + path = case uriPath uri of + ('/':_) -> uriPath uri + _ -> '/' : uriPath uri + db = fromMaybe 0 $ readMaybe . textToString . decodeUtf8 =<< + lookup (encodeUtf8 $ fromString "db") query + query = parseSimpleQuery (encodeUtf8 $ fromString $ uriQuery uri) + uriAuth = parseURIAuthority $ uriToAuthorityString uri + +parseRedisScheme :: URI -> Either String ConnectInfo +parseRedisScheme uri = do + uriAuth <- note "Missing or invalid Authority" + $ parseURIAuthority + $ uriToAuthorityString uri + + let h = host uriAuth + let dbNumPart = dropWhile (== '/') (uriPath uri) + + db <- if null dbNumPart + then return $ connectDatabase defaultConnectInfo + else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart + + return defaultConnectInfo + { connectHost = if null h + then connectHost defaultConnectInfo + else h + , connectPort = maybe (connectPort defaultConnectInfo) + (PortNumber . fromIntegral) $ port uriAuth + , connectAuth = C8.pack <$> password uriAuth + , connectDatabase = db + } diff --git a/cheogram-sip.cabal b/cheogram-sip.cabal index 4625fd9..9e353c4 100644 --- a/cheogram-sip.cabal +++ b/cheogram-sip.cabal @@ -21,12 +21,17 @@ common defs clock >=0.7 && <0.8, errors >=2.3 && <2.4, focus >= 1.0.1 && < 1.1, + hedis, + HTTP, + http-types, lens >=4.16 && <4.17, mime-mail >=0.4 && < 0.5, + monad-loops, network >= 2.6.3 && < 2.7, network-protocol-xmpp >=0.4 && <0.5, network-uri >=2.6 && <2.7, purebred-email >=0.4.1 && <0.5, + safe, stm >=2.4 && <2.5, stm-containers >= 1.1.0 && < 1.2, stm-delay >=0.1 && <0.2, @@ -38,4 +43,5 @@ common defs executable gateway import: defs - main-is: gateway.hs \ No newline at end of file + main-is: gateway.hs + other-modules: Util, RedisURL \ No newline at end of file diff --git a/gateway.hs b/gateway.hs index 7f5084d..209346c 100644 --- a/gateway.hs +++ b/gateway.hs @@ -6,18 +6,24 @@ import System.IO (stdout, stderr, hSetBuffering, BufferMode(LineBuffering)) import Control.Concurrent (threadDelay) import Control.Concurrent.STM (STM) +import Data.Either (fromRight) import Control.Error (exceptT, ExceptT(..), headZ, throwE, lastZ) +import Safe (maximumByMay) import Control.Lens (over, set, at, _Right, traverseOf) import Network (PortID (PortNumber)) import System.Clock (TimeSpec(..)) import Data.Time.Clock (getCurrentTime) +import Control.Monad.Loops (anyM) import qualified Focus import qualified Data.Text as T +import qualified Data.ByteString as B import qualified Data.Cache as Cache +import qualified Database.Redis as Redis import qualified Network.Protocol.XMPP as XMPP import qualified Network.Protocol.XMPP.Internal as XMPP import qualified Data.XML.Types as XML +import qualified RedisURL import Util Just asteriskJid = XMPP.parseJID $ s"asterisk" @@ -95,11 +101,13 @@ main = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering - (componentJidTxt:host:portTxt:secret:[]) <- getArgs + (componentJidTxt:host:portTxt:secret:redisURL:[]) <- getArgs let Just componentJid = XMPP.parseJID componentJidTxt let port = PortNumber $ read portTxt let server = XMPP.Server componentJid (textToString host) port + let Right redisConnectInfo = RedisURL.parseConnectInfo $ textToString redisURL + redis <- Redis.checkedConnect redisConnectInfo sessionInitiates <- Cache.newCache (Just $ TimeSpec 900 0) fullJids <- Cache.newCache (Just $ TimeSpec 900 0) -- exceptT print return $ runRoutedComponent server secret $ do @@ -114,17 +122,30 @@ main = do Just (iq, sid) <- sessionInitiateId stanza -> do let Just (to, from) = asteriskToReal componentJid $ receivedTo stanza liftIO $ Cache.purgeExpired sessionInitiates - liftIO $ Cache.insert sessionInitiates sid iq - XMPP.putStanza $ (XMPP.emptyMessage XMPP.MessageNormal) { - XMPP.messageID = Just $ s"proposal%" ++ sid, - XMPP.messageTo = Just to, - XMPP.messageFrom = Just from, - XMPP.messagePayloads = [ - XML.Element (s"{urn:xmpp:jingle-message:0}propose") - [(s"id", [XML.ContentText sid])] - [XML.NodeElement $ XML.Element (s"{urn:xmpp:jingle:apps:rtp:1}description") [(s"media", [XML.ContentText $ s"audio"])] []] - ] - } + + mostAvailable <- liftIO $ Redis.runRedis redis $ do + Right resources <- Redis.hgetall (encodeUtf8 $ bareTxt to) + jingleMessage <- anyM (fmap (fromRight False) . flip Redis.sismember (s"urn:xmpp:jingle-message:0")) $ map (B.drop 2 . snd) resources + -- TODO: check if mostAvailable supports jingle audio. really we want most available that does + return $ mfilter (const $ not jingleMessage) $ + (decodeUtf8 . fst <$> maximumByMay (comparing snd) resources) + + case mostAvailable of + Just resource | Just fullToJid <- XMPP.parseJID (bareTxt to ++ s"/" ++ resource) -> do + liftIO $ Cache.insert fullJids sid fullToJid + bounceStanza (XMPP.ReceivedIQ iq) from fullToJid + _ -> do + liftIO $ Cache.insert sessionInitiates sid iq + XMPP.putStanza $ (XMPP.emptyMessage XMPP.MessageNormal) { + XMPP.messageID = Just $ s"proposal%" ++ sid, + XMPP.messageTo = Just to, + XMPP.messageFrom = Just from, + XMPP.messagePayloads = [ + XML.Element (s"{urn:xmpp:jingle-message:0}propose") + [(s"id", [XML.ContentText sid])] + [XML.NodeElement $ XML.Element (s"{urn:xmpp:jingle:apps:rtp:1}description") [(s"media", [XML.ContentText $ s"audio"])] []] + ] + } Just sfrom | sfrom == asteriskJid -> let Just (to, from) = asteriskToReal componentJid $ receivedTo stanza -- 2.34.2