~singpolyma/cheogram-sip

290130e42955ccc2406a224b6bc05792258d2eb3 — Stephen Paul Weber 4 months ago c12de66
Allow functioning also as PSTN gateway a bit
1 files changed, 51 insertions(+), 28 deletions(-)

M gateway.hs
M gateway.hs => gateway.hs +51 -28
@@ 62,16 62,16 @@ gatewayDiscoFeatures = [
		s"jid\\20escaping"
	]

gatewayCapsHash :: Text
gatewayCapsHash = decodeUtf8 $ Base64.encode $ discoToCapsHash (gatewayDiscoInfo $ XML.Element (s"x") [] [])
gatewayCapsHash :: [XML.Element] -> Text
gatewayCapsHash extra = decodeUtf8 $ Base64.encode $ discoToCapsHash (gatewayDiscoInfo (XML.Element (s"x") [] []) extra)

gatewayDiscoInfo :: XML.Element -> XML.Element
gatewayDiscoInfo q = XML.Element (s"{http://jabber.org/protocol/disco#info}query")
gatewayDiscoInfo :: XML.Element -> [XML.Element] -> XML.Element
gatewayDiscoInfo q extra = 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
			XML.NodeElement (mkDiscoIdentity (s"gateway") (s"sip") (s"Cheogram SIP")) : map XML.NodeElement extra ++ map (XML.NodeElement . mkDiscoFeature) gatewayDiscoFeatures

gatewayAvailable :: XMPP.JID -> XMPP.JID -> XMPP.Presence
gatewayAvailable from to =
gatewayAvailable :: XMPP.JID -> XMPP.JID -> [XML.Element] -> XMPP.Presence
gatewayAvailable from to capsExtra =
	(XMPP.emptyPresence XMPP.PresenceAvailable) {
		XMPP.presenceTo = Just to,
		XMPP.presenceFrom = XMPP.parseJID $ bareTxt from ++ s"/gateway",


@@ 79,7 79,7 @@ gatewayAvailable from to =
			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])
				(s"{http://jabber.org/protocol/caps}ver", [XML.ContentText $ gatewayCapsHash capsExtra])
			] []
		]
	}


@@ 115,25 115,34 @@ bounceStanza (XMPP.ReceivedPresence p) from to =
		XMPP.presenceTo = Just to
	}

asteriskToReal :: XMPP.JID -> Maybe XMPP.JID -> Maybe (XMPP.JID, XMPP.JID)
asteriskToReal componentJid (Just XMPP.JID {
asteriskToReal :: XMPP.JID -> Maybe Text -> Maybe XMPP.JID -> Maybe (XMPP.JID, XMPP.JID)
asteriskToReal componentJid mpstnDomain (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"@" ++
		escapeJid (stripPstn $ unescapeJid $ XMPP.strResource escapedFrom) ++ s"@" ++
		bareTxt componentJid ++ s"/sip"
	)
asteriskToReal _ _ = Nothing
	where
	stripPstn txt
		| Just pstnDomain <- mpstnDomain = fromMaybe txt $ T.stripSuffix (s"@" ++ pstnDomain) txt
                | otherwise = txt
asteriskToReal _ _ _ = Nothing

realToAsterisk :: XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID
realToAsterisk componentJid (Just from) (Just XMPP.JID {
realToAsterisk :: XMPP.JID -> Maybe Text -> Maybe XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID
realToAsterisk componentJid mpstnDomain (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
	escapeJid resource
	where
	resource
		| not ((s"@") `T.isInfixOf` unescapedTo), Just pstnDomain <- mpstnDomain = unescapedTo ++ s"@" ++ pstnDomain
		| otherwise = unescapedTo
	unescapedTo = unescapeJid $ XMPP.strNode escapedTo
realToAsterisk _ _ _ _ = Nothing

receivedFrom :: XMPP.ReceivedStanza -> Maybe XMPP.JID
receivedFrom (XMPP.ReceivedMessage stanza) = XMPP.stanzaFrom stanza


@@ 173,13 182,13 @@ 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
forwardOn :: XMPP.JID -> Maybe Text -> Cache.Cache Text XMPP.JID -> XMPP.ReceivedStanza -> XMPP.XMPP ()
forwardOn componentJid mpstnDomain 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
	Just (to, from) = asteriskToReal componentJid mpstnDomain $ receivedTo stanza
	msid = jingleSid stanza <|> receivedIqId stanza

main :: IO ()


@@ 195,7 204,7 @@ main = do
	mredis <- case RedisURL.parseConnectInfo $ textToString (fromMaybe mempty $ headZ rest) of
	  Right redisConnectInfo -> fmap Just $ Redis.checkedConnect redisConnectInfo
	  Left _ -> do
	    print "No valid Redis specified, skiping..."
	    putStrLn $ s"No valid Redis specified, skipping..."
	    return Nothing

	sessionInitiates <- Cache.newCache (Just $ TimeSpec 900 0)


@@ 208,6 217,20 @@ main = do
		else
			XMPP.parseJID $ s"asterisk"

	let capsExtra =
		if length rest > 2 then
			[mkDiscoIdentity (s"gateway") (s"pstn") (s"Cheogram SIP")]
		else
			[]

	let mpstnDomain =
		if length rest > 2 then
			Just (rest !! 2)
		else
			Nothing

	forM_ mpstnDomain $ \pstn -> putStrLn $ s"Starting as PSTN gateway also, via " ++ pstn

	Right () <- XMPP.runComponent server secret $ forever $ do
		stanza <- XMPP.getStanza
		case receivedFrom stanza of


@@ 216,7 239,7 @@ main = do
			Just sfrom
				| sfrom == asteriskJid,
				  Just (iq, sid) <- sessionInitiateId stanza -> do
					let Just (to, from) = asteriskToReal componentJid $ receivedTo stanza
					let Just (to, from) = asteriskToReal componentJid mpstnDomain $ receivedTo stanza
					liftIO $ Cache.purgeExpired sessionInitiates

					mostAvailable <- case mredis of


@@ 247,7 270,7 @@ main = do
								}
			Just sfrom
				| sfrom == asteriskJid,
				  Just (to, from) <- asteriskToReal componentJid $ receivedTo stanza,
				  Just (to, from) <- asteriskToReal componentJid mpstnDomain $ receivedTo stanza,
				  Just sid <- sessionTerminateId stanza -> do
					mIq <- liftIO $ Cache.lookup' sessionInitiates sid
					case mIq of


@@ 264,9 287,9 @@ main = do
										XML.Element (s"{urn:xmpp:hints}store") [] []
									]
								}
						Nothing -> forwardOn componentJid fullJids stanza
						Nothing -> forwardOn componentJid mpstnDomain fullJids stanza
			Just sfrom | sfrom == asteriskJid ->
				forwardOn componentJid fullJids stanza
				forwardOn componentJid mpstnDomain fullJids stanza
			sfrom
				| XMPP.ReceivedPresence presence <- stanza,
				  Just from <- sfrom,


@@ 282,21 305,21 @@ main = do
						}
					XMPP.putStanza $ case XMPP.jidNode to of
						Just _ -> sipAvailable to from
						Nothing -> gatewayAvailable to from
						Nothing -> gatewayAvailable to from capsExtra
				| 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
						Nothing -> gatewayAvailable to from capsExtra
				| 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
						Nothing -> iqReply (Just $ gatewayDiscoInfo query capsExtra) iq
				| XMPP.ReceivedMessage m <- stanza,
				  Just from <- sfrom,
				  Just to <- XMPP.stanzaTo m,


@@ 354,7 377,7 @@ main = do
					forM_ minit $ \ini -> do
						liftIO $ Cache.delete sessionInitiates sid
						XMPP.putStanza $ iqError errPayload ini
				| Just from <- realToAsterisk componentJid sfrom (receivedTo stanza) -> do
				| Just from <- realToAsterisk componentJid mpstnDomain 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 ->