M Util.hs => Util.hs +60 -0
@@ 6,6 6,7 @@ import Control.Concurrent.STM (STM, atomically)
import Control.Applicative (many)
import Control.Concurrent
(ThreadId, forkFinally, myThreadId, throwTo)
+import Data.Digest.Pure.SHA (sha1, bytestringDigest)
import Data.Void (absurd)
import Control.Error (exceptT)
import Data.Time.Clock (UTCTime)
@@ 17,6 18,7 @@ import qualified Data.XML.Types as XML
import qualified Network.Protocol.XMPP as XMPP
import UnexceptionalIO.Trans (Unexceptional (lift))
import qualified UnexceptionalIO.Trans as UIO
+import qualified Data.ByteString.Lazy as LZ
instance Unexceptional XMPP.XMPP where
lift = liftIO . UIO.run
@@ 181,3 183,61 @@ mkDiscoFeature var =
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)
+
+discoCapsIdentities :: XML.Element -> [Text]
+discoCapsIdentities query =
+ sort $
+ map (\identity -> mconcat $ intersperse (s"/") [
+ attrOrBlank (s"category") identity,
+ attrOrBlank (s"type") identity,
+ attrOrBlank (s"xml:lang") identity,
+ attrOrBlank (s"name") identity
+ ]) $
+ XML.isNamed (s"{http://jabber.org/protocol/disco#info}identity") =<<
+ XML.elementChildren query
+
+discoVars :: XML.Element -> [Text]
+discoVars query =
+ mapMaybe (XML.attributeText (s"var")) $
+ XML.isNamed (s"{http://jabber.org/protocol/disco#info}feature") =<<
+ XML.elementChildren query
+
+data DiscoForm = DiscoForm Text [(Text, [Text])] deriving (Show, Ord, Eq)
+
+oneDiscoForm :: XML.Element -> DiscoForm
+oneDiscoForm form =
+ DiscoForm form_type (filter ((/= s"FORM_TYPE") . fst) fields)
+ where
+ form_type = mconcat $ fromMaybe [] $ lookup (s"FORM_TYPE") fields
+ fields = sort $ map (\field ->
+ (
+ attrOrBlank (s"var") field,
+ sort (map (mconcat . XML.elementText) $ XML.isNamed (s"{jabber:x:data}value") =<< XML.elementChildren form)
+ )
+ ) $
+ XML.isNamed (s"{jabber:x:data}field") =<<
+ XML.elementChildren form
+
+discoForms :: XML.Element -> [DiscoForm]
+discoForms query =
+ sort $
+ map oneDiscoForm $
+ XML.isNamed (s"{jabber:x:data}x") =<<
+ XML.elementChildren query
+
+discoCapsForms :: XML.Element -> [Text]
+discoCapsForms query =
+ concatMap (\(DiscoForm form_type fields) ->
+ form_type : concatMap (uncurry (:)) fields
+ ) (discoForms query)
+
+discoToCaps :: XML.Element -> Text
+discoToCaps query =
+ (mconcat $ intersperse (s"<") (discoCapsIdentities query ++ discoVars query ++ discoCapsForms query)) ++ s"<"
+
+discoToCapsHash :: XML.Element -> ByteString
+discoToCapsHash query =
+ LZ.toStrict $ bytestringDigest $ sha1 $ LZ.fromStrict $ encodeUtf8 $ discoToCaps query
+
+attrOrBlank :: XML.Name -> XML.Element -> Text
+attrOrBlank name el = fromMaybe mempty $ XML.attributeText name el
R extensions.lua => asterisk-conf/extensions.lua +24 -0
@@ 13,6 13,19 @@ function jid_escape(s)
:gsub("@", "\\40")
end
+function jid_unescape(s)
+ return s
+ :gsub("\\20", " ")
+ :gsub("\\22", "\"")
+ :gsub("\\26", "&")
+ :gsub("\\27", "'")
+ :gsub("\\2f", "/")
+ :gsub("\\3a", ":")
+ :gsub("\\3c", "<")
+ :gsub("\\3e", ">")
+ :gsub("\\40", "@")
+end
+
function make_jid(extension, from_header)
return (
jid_escape(extension)
@@ 48,4 61,15 @@ extensions = {
end
end;
};
+
+ ["jingle"] = {
+ ["jingle-endpoint"] = function(context, extension)
+ local jid = channel.CALLERID("name"):get()
+ local from = jid_unescape(jid:sub(0, jid:find("@") - 1))
+ local to = jid_unescape(jid:sub(jid:find("/") + 1))
+ app.log("NOTICE", from)
+ channel.CALLERID("all"):set(from .. "<" .. from .. ">")
+ app.dial("SIP/" .. to:gsub("\\", "\\\\"):gsub("&", "") .. "!!" .. from .. "@sip.cheogram.com")
+ end;
+ };
}
M cheogram-sip.cabal => cheogram-sip.cabal +2 -0
@@ 14,6 14,7 @@ common defs
ghc-options: -Wall -Wno-tabs -Wno-orphans
build-depends: base >=4.11 && <4.12,
attoparsec >=0.13 && <0.14,
+ base64-bytestring,
basic-prelude >=0.7 && <0.8,
bytestring >=0.10 && <0.11,
cache >=0.1 && <0.2,
@@ 32,6 33,7 @@ common defs
network-uri >=2.6 && <2.7,
purebred-email >=0.4.1 && <0.5,
safe,
+ SHA,
stm >=2.4 && <2.5,
stm-containers >= 1.1.0 && < 1.2,
stm-delay >=0.1 && <0.2,
M gateway.hs => gateway.hs +73 -1
@@ 17,6 17,7 @@ import Control.Monad.Loops (anyM)
import qualified Focus
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
@@ 28,6 29,36 @@ import Util
Just asteriskJid = XMPP.parseJID $ s"asterisk"
+sipCapsHash = decodeUtf8 $ Base64.encode $ discoToCapsHash (sipDiscoInfo $ XML.Element (s"x") [] [])
+
+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 = [
+ 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 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)
+
rewriteJingleInitiatorResponder iq
| Just jingle <- child (s"{urn:xmpp:jingle:1}jingle") iq = iq {
XMPP.iqPayload = Just $ jingle {
@@ 155,6 186,45 @@ main = do
liftIO $ forM_ msid $ \sid -> forM_ fullTo $ Cache.insert fullJids sid
bounceStanza stanza from (fromMaybe to fullTo)
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 $ sipAvailable to from
+ | XMPP.ReceivedPresence presence <- stanza,
+ Just from <- sfrom,
+ Just to <- XMPP.stanzaTo presence,
+ XMPP.PresenceProbe <- XMPP.presenceType presence -> do
+ XMPP.putStanza $ sipAvailable to from
+ | XMPP.ReceivedIQ iq <- stanza,
+ Just from <- sfrom,
+ Just to <- XMPP.stanzaTo iq,
+ Just query <- child (s"{http://jabber.org/protocol/disco#info}query") iq ->
+ XMPP.putStanza $ iqReply (Just $ sipDiscoInfo 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,
@@ 196,7 266,9 @@ main = do
forM_ minit $ \init -> do
liftIO $ Cache.delete sessionInitiates sid
XMPP.putStanza $ iqError errPayload init
- | Just from <- realToAsterisk componentJid sfrom (receivedTo stanza) ->
+ | Just from <- realToAsterisk componentJid sfrom (receivedTo stanza) -> do
+ liftIO $ forM_ sfrom $ \fullFrom -> forM_ (sessionInitiateId stanza) $ \(_, sid) ->
+ Cache.insert fullJids sid fullFrom
bounceStanza stanza from asteriskJid
| otherwise ->
print ("DUNNO", stanza)