A RedisURL.hs => RedisURL.hs +95 -0
@@ 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
+ }
M cheogram-sip.cabal => cheogram-sip.cabal +7 -1
@@ 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
M gateway.hs => gateway.hs +33 -12
@@ 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