module Main (main) where
import Prelude ()
import BasicPrelude
import System.IO
(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Data.Either (fromRight)
import Control.Error (lastZ)
import Safe (maximumByMay)
import Network (PortID (PortNumber))
import System.Clock (TimeSpec(..))
import Control.Monad.Loops (anyM)
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Cache as Cache
import qualified Database.Redis as Redis
import qualified Network.Protocol.XMPP as XMPP
import qualified Data.XML.Types as XML
import qualified RedisURL
import Util
asteriskJid :: XMPP.JID
Just asteriskJid = XMPP.parseJID $ s"asterisk"
sipCapsHash :: Text
sipCapsHash = decodeUtf8 $ Base64.encode $ discoToCapsHash (sipDiscoInfo $ XML.Element (s"x") [] [])
sipAvailable :: XMPP.JID -> XMPP.JID -> XMPP.Presence
sipAvailable from to =
(XMPP.emptyPresence XMPP.PresenceAvailable) {
XMPP.presenceTo = Just to,
XMPP.presenceFrom = XMPP.parseJID $ bareTxt from ++ s"/sip",
XMPP.presencePayloads = [
XML.Element (s"{http://jabber.org/protocol/caps}c") [
(s"{http://jabber.org/protocol/caps}hash", [XML.ContentText $ s"sha-1"]),
(s"{http://jabber.org/protocol/caps}node", [XML.ContentText $ s "xmpp:sip.cheogram.com"]),
(s"{http://jabber.org/protocol/caps}ver", [XML.ContentText sipCapsHash])
] []
]
}
sipDiscoFeatures :: [Text]
sipDiscoFeatures = [
s"http://jabber.org/protocol/caps",
s"http://jabber.org/protocol/disco#info",
s"urn:xmpp:jingle-message:0",
s"urn:xmpp:jingle:1",
s"urn:xmpp:jingle:apps:dtls:0",
s"urn:xmpp:jingle:apps:rtp:1",
s"urn:xmpp:jingle:apps:rtp:audio",
s"urn:xmpp:jingle:transports:ice-udp:1"
]
sipDiscoInfo :: XML.Element -> XML.Element
sipDiscoInfo q = XML.Element (s"{http://jabber.org/protocol/disco#info}query")
(map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [XML.ContentText node])) $ maybeToList $ XML.attributeText (s"node") q) $
XML.NodeElement (mkDiscoIdentity (s"client") (s"phone") (s"Cheogram SIP")) : map (XML.NodeElement . mkDiscoFeature) sipDiscoFeatures
gatewayDiscoFeatures :: [Text]
gatewayDiscoFeatures = [
s"http://jabber.org/protocol/caps",
s"http://jabber.org/protocol/disco#info",
s"jid\\20escaping"
]
gatewayCapsHash :: Text
gatewayCapsHash = decodeUtf8 $ Base64.encode $ discoToCapsHash (gatewayDiscoInfo $ XML.Element (s"x") [] [])
gatewayDiscoInfo :: XML.Element -> XML.Element
gatewayDiscoInfo q = XML.Element (s"{http://jabber.org/protocol/disco#info}query")
(map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [XML.ContentText node])) $ maybeToList $ XML.attributeText (s"node") q) $
XML.NodeElement (mkDiscoIdentity (s"gateway") (s"sip") (s"Cheogram SIP")) : map (XML.NodeElement . mkDiscoFeature) gatewayDiscoFeatures
gatewayAvailable :: XMPP.JID -> XMPP.JID -> XMPP.Presence
gatewayAvailable from to =
(XMPP.emptyPresence XMPP.PresenceAvailable) {
XMPP.presenceTo = Just to,
XMPP.presenceFrom = XMPP.parseJID $ bareTxt from ++ s"/gateway",
XMPP.presencePayloads = [
XML.Element (s"{http://jabber.org/protocol/caps}c") [
(s"{http://jabber.org/protocol/caps}hash", [XML.ContentText $ s"sha-1"]),
(s"{http://jabber.org/protocol/caps}node", [XML.ContentText $ s "xmpp:sip.cheogram.com"]),
(s"{http://jabber.org/protocol/caps}ver", [XML.ContentText gatewayCapsHash])
] []
]
}
rewriteJingleInitiatorResponder :: XMPP.IQ -> XMPP.IQ
rewriteJingleInitiatorResponder iq
| Just jingle <- child (s"{urn:xmpp:jingle:1}jingle") iq = iq {
XMPP.iqPayload = Just $ jingle {
XML.elementAttributes = map initiatorResponder (XML.elementAttributes jingle)
}
}
| otherwise = iq
where
initiatorResponder (name, content)
| name == s"initiator" = (name, [XML.ContentText $ maybe (s"") XMPP.formatJID (XMPP.iqFrom iq)])
| name == s"responder" = (name, [XML.ContentText $ maybe (s"") XMPP.formatJID (XMPP.iqFrom iq)])
| otherwise = (name, content)
bounceStanza :: XMPP.ReceivedStanza -> XMPP.JID -> XMPP.JID -> XMPP.XMPP ()
bounceStanza (XMPP.ReceivedMessage m) from to =
XMPP.putStanza $ m {
XMPP.messageFrom = Just from,
XMPP.messageTo = Just to
}
bounceStanza (XMPP.ReceivedIQ iq) from to =
XMPP.putStanza $ rewriteJingleInitiatorResponder $ iq {
XMPP.iqFrom = Just from,
XMPP.iqTo = Just to
}
bounceStanza (XMPP.ReceivedPresence p) from to =
XMPP.putStanza $ p {
XMPP.presenceFrom = Just from,
XMPP.presenceTo = Just to
}
asteriskToReal :: XMPP.JID -> Maybe XMPP.JID -> Maybe (XMPP.JID, XMPP.JID)
asteriskToReal componentJid (Just XMPP.JID {
XMPP.jidNode = Just escapedTo,
XMPP.jidResource = Just escapedFrom
}) = (,) <$> XMPP.parseJID (unescapeJid $ XMPP.strNode escapedTo) <*>
XMPP.parseJID (
escapeJid (unescapeJid $ XMPP.strResource escapedFrom) ++ s"@" ++
bareTxt componentJid ++ s"/sip"
)
asteriskToReal _ _ = Nothing
realToAsterisk :: XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID
realToAsterisk componentJid (Just from) (Just XMPP.JID {
XMPP.jidNode = Just escapedTo
}) = XMPP.parseJID $
escapeJid (bareTxt from) ++ s"@" ++
bareTxt componentJid ++ s"/" ++
escapeJid (unescapeJid $ XMPP.strNode escapedTo)
realToAsterisk _ _ _ = Nothing
receivedFrom :: XMPP.ReceivedStanza -> Maybe XMPP.JID
receivedFrom (XMPP.ReceivedMessage stanza) = XMPP.stanzaFrom stanza
receivedFrom (XMPP.ReceivedPresence stanza) = XMPP.stanzaFrom stanza
receivedFrom (XMPP.ReceivedIQ stanza) = XMPP.stanzaFrom stanza
receivedTo :: XMPP.ReceivedStanza -> Maybe XMPP.JID
receivedTo (XMPP.ReceivedMessage stanza) = XMPP.stanzaTo stanza
receivedTo (XMPP.ReceivedPresence stanza) = XMPP.stanzaTo stanza
receivedTo (XMPP.ReceivedIQ stanza) = XMPP.stanzaTo stanza
jingleSid :: XMPP.ReceivedStanza -> Maybe Text
jingleSid (XMPP.ReceivedIQ iq)
| Just jingle <- child (s"{urn:xmpp:jingle:1}jingle") iq =
XML.attributeText (s"sid") jingle
jingleSid _ = Nothing
receivedIqId :: XMPP.ReceivedStanza -> Maybe Text
receivedIqId (XMPP.ReceivedIQ (XMPP.IQ { XMPP.iqID = Just iqID })) = Just iqID
receivedIqId _ = Nothing
sessionInitiateId :: XMPP.ReceivedStanza -> Maybe (XMPP.IQ, Text)
sessionInitiateId (XMPP.ReceivedIQ iq)
| Just jingle <- child (s"{urn:xmpp:jingle:1}jingle") iq,
XML.attributeText (s"action") jingle == Just (s"session-initiate") =
(,) iq <$> XML.attributeText (s"sid") jingle
sessionInitiateId _ = Nothing
-- Return the sessionID of a session-terminate, and Nothing if it's something else
-- (or the terminate doesn't have a session somehow)
sessionTerminateId :: XMPP.ReceivedStanza -> Maybe Text
sessionTerminateId (XMPP.ReceivedIQ iq)
| Just jingle <- child (s"{urn:xmpp:jingle:1}jingle") iq,
XML.attributeText (s"action") jingle == Just (s"session-terminate") =
XML.attributeText (s"sid") jingle
sessionTerminateId _ = Nothing
-- Decodes the JID and otherwise fowards the stanza on as-is
-- Also keeps the fullJidCache fresh
forwardOn :: XMPP.JID -> Cache.Cache Text XMPP.JID -> XMPP.ReceivedStanza -> XMPP.XMPP ()
forwardOn componentJid fullJidCache stanza = do
fullTo <- liftIO $ maybe (return Nothing) (Cache.lookup' fullJidCache) msid
liftIO $ forM_ msid $ \sid -> forM_ fullTo $ Cache.insert fullJidCache sid
bounceStanza stanza from (fromMaybe to fullTo)
where
Just (to, from) = asteriskToReal componentJid $ receivedTo stanza
msid = jingleSid stanza <|> receivedIqId stanza
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
[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
Right () <- XMPP.runComponent server secret $ forever $ do
stanza <- XMPP.getStanza
case receivedFrom stanza of
_ | XMPP.ReceivedIQ iq <- stanza,
XMPP.iqID iq == Just (s"CHEOGRAMIGNORE") -> return ()
Just sfrom
| sfrom == asteriskJid,
Just (iq, sid) <- sessionInitiateId stanza -> do
let Just (to, from) = asteriskToReal componentJid $ receivedTo stanza
liftIO $ Cache.purgeExpired sessionInitiates
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.MessageChat) {
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,
Just (to, from) <- asteriskToReal componentJid $ receivedTo stanza,
Just sid <- sessionTerminateId stanza -> do
mIq <- liftIO $ Cache.lookup' sessionInitiates sid
case mIq of
Just _ -> do
liftIO $ Cache.delete sessionInitiates sid
XMPP.putStanza $ (XMPP.emptyMessage XMPP.MessageChat) {
XMPP.messageID = Just $ s"retract%" ++ sid,
XMPP.messageTo = Just to,
XMPP.messageFrom = Just from,
XMPP.messagePayloads = [
XML.Element (s"{urn:xmpp:jingle-message:0}retract")
[(s"id", [XML.ContentText sid])]
[]
]
}
Nothing -> forwardOn componentJid fullJids stanza
Just sfrom | sfrom == asteriskJid ->
forwardOn componentJid fullJids stanza
sfrom
| XMPP.ReceivedPresence presence <- stanza,
Just from <- sfrom,
Just to <- XMPP.stanzaTo presence,
XMPP.PresenceSubscribe <- XMPP.presenceType presence -> do
XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceSubscribed) {
XMPP.presenceTo = Just from,
XMPP.presenceFrom = Just to
}
XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceSubscribe) {
XMPP.presenceTo = Just from,
XMPP.presenceFrom = Just to
}
XMPP.putStanza $ case XMPP.jidNode to of
Just _ -> sipAvailable to from
Nothing -> gatewayAvailable to from
| XMPP.ReceivedPresence presence <- stanza,
Just from <- sfrom,
Just to <- XMPP.stanzaTo presence,
XMPP.PresenceProbe <- XMPP.presenceType presence ->
XMPP.putStanza $ case XMPP.jidNode to of
Just _ -> sipAvailable to from
Nothing -> gatewayAvailable to from
| XMPP.ReceivedIQ iq <- stanza,
Just _ <- sfrom,
Just to <- XMPP.stanzaTo iq,
Just query <- child (s"{http://jabber.org/protocol/disco#info}query") iq ->
XMPP.putStanza $ case XMPP.jidNode to of
Just _ -> iqReply (Just $ sipDiscoInfo query) iq
Nothing -> iqReply (Just $ gatewayDiscoInfo query) iq
| XMPP.ReceivedMessage m <- stanza,
Just from <- sfrom,
Just to <- XMPP.stanzaTo m,
Just propose <- child (s"{urn:xmpp:jingle-message:0}propose") m -> do
let sid = fromMaybe mempty $ XML.attributeText (s"id") propose
liftIO $ Cache.insert fullJids sid from
XMPP.putStanza $ (XMPP.emptyMessage XMPP.MessageNormal) {
XMPP.messageID = Just $ s"proceed%" ++ sid,
XMPP.messageTo = Just from,
XMPP.messageFrom = XMPP.parseJID $ bareTxt to ++ s"/sip",
XMPP.messagePayloads = [
XML.Element (s"{urn:xmpp:jingle-message:0}proceed")
[(s"id", [XML.ContentText sid])] []
]
}
-- TODO: directed presence
| XMPP.ReceivedMessage m <- stanza,
Just from <- sfrom,
Just to <- XMPP.stanzaTo m,
Just proceed <- child (s"{urn:xmpp:jingle-message:0}proceed") m -> do
let sid = fromMaybe mempty $ XML.attributeText (s"id") proceed
minit <- liftIO $ Cache.lookup' sessionInitiates sid
forM_ minit $ \ini -> do
liftIO $ Cache.delete sessionInitiates sid
liftIO $ Cache.insert fullJids sid from
bounceStanza (XMPP.ReceivedIQ ini) to from
| XMPP.ReceivedMessage m <- stanza,
Just _ <- sfrom,
Just _ <- XMPP.stanzaTo m,
Just reject <- child (s"{urn:xmpp:jingle-message:0}reject") m -> do
let sid = fromMaybe mempty $ XML.attributeText (s"id") reject
minit <- liftIO $ Cache.lookup' sessionInitiates sid
forM_ minit $ \ini -> do
liftIO $ Cache.delete sessionInitiates sid
XMPP.putStanza $ iqReply Nothing ini
XMPP.putStanza $ (XMPP.emptyIQ XMPP.IQSet) {
XMPP.iqID = Just $ s"CHEOGRAMIGNORE",
XMPP.iqTo = XMPP.iqFrom ini,
XMPP.iqFrom = XMPP.iqTo ini,
XMPP.iqPayload = Just $ XML.Element
(s"{urn:xmpp:jingle:1}jingle")
[
(s"action", [XML.ContentText $ s"session-terminate"]),
(s"sid", [XML.ContentText sid])
]
[XML.NodeElement $ XML.Element (s"{urn:xmpp:jingle:1}reason") [] [
XML.NodeElement $ XML.Element (s"{urn:xmpp:jingle:1}decline") [] []
]]
}
| XMPP.ReceivedMessage m <- stanza,
XMPP.messageType m == XMPP.MessageError,
Just errPayload <- lastZ $ XMPP.messagePayloads m,
Just sid <- T.stripPrefix (s"proposal%") =<< XMPP.messageID m -> do
minit <- liftIO $ Cache.lookup' sessionInitiates sid
forM_ minit $ \ini -> do
liftIO $ Cache.delete sessionInitiates sid
XMPP.putStanza $ iqError errPayload ini
| Just from <- realToAsterisk componentJid sfrom (receivedTo stanza) -> do
liftIO $ forM_ sfrom $ \fullFrom -> forM_ (sessionInitiateId stanza) $ \(_, sid) ->
Cache.insert fullJids sid fullFrom
liftIO $ forM_ sfrom $ \fullFrom -> forM_ (receivedIqId stanza) $ \iqID ->
Cache.insert fullJids iqID fullFrom
bounceStanza stanza from asteriskJid
| XMPP.ReceivedIQ iq <- stanza,
XMPP.iqType iq `elem` [XMPP.IQGet, XMPP.IQSet] ->
XMPP.putStanza $ iqError notImplemented iq
| otherwise ->
print ("DUNNO", stanza)
return ()