~singpolyma/cheogram-sip

75446aa2af3a24279f230eba23d7cb66c6778a85 — Stephen Paul Weber 3 years ago d993c60
Outbound calls work
4 files changed, 159 insertions(+), 1 deletions(-)

M Util.hs
R extensions.lua => asterisk-conf/extensions.lua
M cheogram-sip.cabal
M gateway.hs
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)