@@ 63,16 63,16 @@ tcPut db cheoJid key val = liftIO $ do
True <- TC.runTCM (TC.put db tck val)
return ()
-queryDisco to from = queryDiscoWithNode Nothing to from
+queryDisco to from = (:[]) . mkStanzaRec <$> queryDiscoWithNode Nothing to from
queryDiscoWithNode node to from = do
uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
- return [mkStanzaRec $ (emptyIQ IQGet) {
+ return $ (emptyIQ IQGet) {
iqTo = Just to,
iqFrom = Just from,
iqID = uuid,
iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") (map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [ContentText node])) $ maybeToList node) []
- }]
+ }
fillFormField var value form = form {
elementNodes = map (\node ->
@@ 170,6 170,11 @@ telDiscoFeatures = [
s"urn:xmpp:jingle:transports:ibb:1"
]
+getTelFeatures db jid = do
+ maybeProxy <- TC.runTCM (TC.get db (T.unpack (bareTxt jid) ++ "\0sip-proxy") :: TC.TCM (Maybe String))
+ log "TELFEATURES" (jid, maybeProxy)
+ return $ maybe [] (const $ [s"urn:xmpp:jingle:transports:ice-udp:1", s"urn:xmpp:jingle:apps:dtls:0", s"urn:xmpp:jingle:apps:rtp:1", s"urn:xmpp:jingle:apps:rtp:audio"]) maybeProxy
+
telCapsStr extraVars =
s"client/sms//Cheogram<" ++ mconcat (intersperse (s"<") (sort (nub (telDiscoFeatures ++ extraVars)))) ++ s"<"
@@ 222,8 227,23 @@ routeQueryOrReply db componentJid from smsJid resource query reply = do
where
maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource)
+routeQueryStateful db componentJid sendIQ from smsJid query = do
+ maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
+ case (fmap fromString maybeRoute, maybeRouteFrom) of
+ (Just route, Just routeFrom) -> do
+ let routeTo = fromMaybe componentJid $ parseJID $ (maybe mempty (++ s"@") $ strNode <$> jidNode smsJid) ++ route
+ iqToSend <- query routeTo routeFrom
+ result <- atomicUIO =<< UIO.lift (sendIQ iqToSend)
+ return $ mfilter ((==IQResult) . iqType) result
+ _ -> return Nothing
+ where
+ maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/IQMANAGER"
+
+routeDiscoStateful db componentJid sendIQ from smsJid node =
+ routeQueryStateful db componentJid sendIQ from smsJid (queryDiscoWithNode node)
+
routeDiscoOrReply db componentJid from smsJid resource node reply =
- routeQueryOrReply db componentJid from smsJid resource (queryDiscoWithNode node) reply
+ routeQueryOrReply db componentJid from smsJid resource (fmap (pure . mkStanzaRec) .: queryDiscoWithNode node) reply
deliveryReceipt id from to =
(emptyMessage MessageNormal) {
@@ 638,7 658,8 @@ data ComponentContext = ComponentContext {
toRejoinManager :: TChan RejoinManagerCommand,
toJoinPartDebouncer :: TChan JoinPartDebounce,
processDirectMessageRouteConfig :: IQ -> IO IQ,
- componentJid :: JID
+ componentJid :: JID,
+ sendIQ :: IQ -> UIO (STM (Maybe IQ))
}
componentStanza :: ComponentContext -> ReceivedStanza -> IO [StanzaRec]
@@ 774,6 795,14 @@ componentStanza (ComponentContext { processDirectMessageRouteConfig, componentJi
return [mkStanzaRec $ replyIQ {
iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
}]
+componentStanza (ComponentContext { db, processDirectMessageRouteConfig, componentJid }) (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = Just payload, iqFrom = Just from }))
+ | jidNode to == Nothing,
+ elementName payload == s"{http://jabber.org/protocol/commands}command",
+ attributeText (s"node") payload == Just (s"sip-proxy-set"),
+ [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren payload,
+ Just proxy <- getFormField form (s"sip-proxy") = do
+ True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) ++ "\0sip-proxy") $ T.unpack proxy
+ return [mkStanzaRec $ iqReply Nothing iq]
componentStanza _ (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
| iqType iq `elem` [IQGet, IQSet],
[_] <- isNamed (fromString "{jabber:iq:register}query") p = do
@@ 829,11 858,17 @@ componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType
where
extra = T.unpack $ escapeJid $ T.pack $ show (id, fromMaybe mempty resourceFrom)
resourceFrom = strResource <$> jidResource from
-componentStanza (ComponentContext { db, smsJid = (Just smsJid), componentJid }) (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p }))
+componentStanza (ComponentContext { db, sendIQ, smsJid = (Just smsJid), componentJid }) (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p }))
| Just _ <- jidNode to,
[q] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
- routeDiscoOrReply db componentJid from smsJid ("CHEOGRAM%query-then-send-disco-info%" ++ extra) (nodeAttribute q) $
- telDiscoInfo q id to from []
+ maybeDiscoResult <- routeDiscoStateful db componentJid sendIQ from smsJid (nodeAttribute q)
+ telFeatures <- getTelFeatures db from
+ case maybeDiscoResult of
+ Just (IQ { iqPayload = Just discoResult }) -> return [
+ mkStanzaRec $ telDiscoInfo q id to from $ (telFeatures ++) $ mapMaybe (attributeText (fromString "var")) $
+ isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren discoResult
+ ]
+ Nothing -> return [mkStanzaRec $ telDiscoInfo q id to from telFeatures]
| Just tel <- strNode <$> jidNode to,
[_] <- isNamed (s"{vcard-temp}vCard") p = do
--owners <- (fromMaybe [] . (readZ =<<)) <$>
@@ 955,12 990,13 @@ componentStanza (ComponentContext { componentJid }) (ReceivedIQ (IQ { iqType = t
else do
let items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren p
return [mkStanzaRec $ commandList componentJid iqId componentJid routeTo items]
-componentStanza (ComponentContext { componentJid }) (ReceivedIQ (IQ { iqType = IQError, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from }))
+componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType = IQError, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from }))
| fmap strResource (jidResource to) == Just (s"CHEOGRAM%query-then-send-presence"),
Just routeTo <- parseJID (unescapeJid (strNode toNode)),
Just fromNode <- jidNode from,
- Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) =
- return [ mkStanzaRec $ telAvailable routeFrom routeTo [] ]
+ Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do
+ telFeatures <- getTelFeatures db routeTo
+ return [ mkStanzaRec $ telAvailable routeFrom routeTo telFeatures ]
componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from, iqPayload = Just p }))
| Just idAndResource <- T.stripPrefix (s"CHEOGRAM%query-then-send-ack%") . strResource =<< jidResource to,
Just (messageId, resource) <- readZ $ T.unpack $ unescapeJid idAndResource,
@@ 973,23 1009,14 @@ componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType
return []
else do
return [mkStanzaRec $ deliveryReceipt messageId routeFrom routeTo]
- | Just idAndResource <- T.stripPrefix (s"CHEOGRAM%query-then-send-disco-info%") . strResource =<< jidResource to,
- Just (iqID, resource) <- readZ $ T.unpack $ unescapeJid idAndResource,
- [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p,
- Just routeTo <- parseJID (unescapeJid (strNode toNode) ++ if T.null resource then mempty else s"/" ++ resource),
- Just fromNode <- jidNode from,
- Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do
- return [
- mkStanzaRec $ telDiscoInfo query iqID routeFrom routeTo $ mapMaybe (attributeText (fromString "var")) $
- isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query
- ]
| fmap strResource (jidResource to) == Just (s"CHEOGRAM%query-then-send-presence"),
[query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p,
Just routeTo <- parseJID (unescapeJid (strNode toNode)),
Just fromNode <- jidNode from,
Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do
+ telFeatures <- getTelFeatures db routeTo
return [
- mkStanzaRec $ telAvailable routeFrom routeTo $ mapMaybe (attributeText (fromString "var")) $
+ mkStanzaRec $ telAvailable routeFrom routeTo $ (telFeatures ++) $ mapMaybe (attributeText (fromString "var")) $
isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query
]
| [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
@@ 1093,7 1120,7 @@ cacheOOB pushStatsd jingleStore jingleStoreURL m@(XMPP.Message { XMPP.messagePay
(body, noOobsNoBody) = partition (\el -> XML.elementName el == bodyName) noOobs
(oobs, noOobs) = partition (\el -> XML.elementName el == oobName) payloads
-component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer toComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do
+component db redis pushStatsd backendHost did cacheOOB sendIQ iqReceiver adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer toComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do
sendThread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do
stanza <- liftIO $ atomically $ readTChan toComponent
@@ 1143,7 1170,7 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB
Redis.exists bver
-- Yes: done
-- No: send disco query, with node
- when (not exists) $ mapM_ sendToComponent =<< queryDiscoWithNode (Just $ node ++ s"#" ++ ver) from returnFrom
+ when (not exists) $ sendToComponent . mkStanzaRec =<< queryDiscoWithNode (Just $ node ++ s"#" ++ ver) from returnFrom
-- No: write only availableness to redis. send disco query, no node
_ -> do
let val = LZ.toStrict $ Builder.toLazyByteString (Builder.word16BE pavailableness)
@@ 1172,8 1199,8 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB
_ -> return ()
flip forkFinallyXMPP (either (log "RECEIVE ONE" . show) return) $ case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza), stanza) of
(_, Just to, _, _, ReceivedIQ iq@(IQ { iqType = IQResult }))
- | (strResource <$> jidResource to) == Just (s"adhocbot") ->
- adhocBotIQReceiver iq
+ | (strResource <$> jidResource to) `elem` map Just [s"adhocbot", s"IQMANAGER"] ->
+ iqReceiver iq
(Just from, Just to, _, _, _)
| strDomain (jidDomain from) == backendHost,
to == componentJid ->
@@ 1263,7 1290,7 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB
(nameNamespace $ elementName p) `elem` [Just (s"urn:xmpp:jingle:1"), Just (s"http://jabber.org/protocol/ibb")] -> do
jingleHandler iq
| otherwise -> liftIO $
- mapM_ sendToComponent =<< componentStanza (ComponentContext db backendTo registrationJids adhocBotMessage cacheOOB toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid) stanza
+ mapM_ sendToComponent =<< componentStanza (ComponentContext db backendTo registrationJids adhocBotMessage cacheOOB toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid sendIQ) stanza
where
mapToComponent = mapToBackend (formatJID componentJid)
sendToComponent = atomically . writeTChan toComponent
@@ 1897,9 1924,9 @@ main = do
statsd <- openStatsD statsdHost (show statsdPort) ["cheogram"]
- (adhocBotIQSender, adhocBotIQReceiver) <- iqManager $ atomicUIO . writeTChan sendToComponent . mkStanzaRec
+ (sendIQ, iqReceiver) <- iqManager $ atomicUIO . writeTChan sendToComponent . mkStanzaRec
adhocBotMessages <- atomically newTChan
- void $ forkIO $ adhocBotManager db componentJid (atomicUIO . writeTChan sendToComponent . mkStanzaRec) adhocBotIQSender (readTChan adhocBotMessages)
+ void $ forkIO $ adhocBotManager db componentJid (atomicUIO . writeTChan sendToComponent . mkStanzaRec) sendIQ (readTChan adhocBotMessages)
void $ forkIO $ joinPartDebouncer db backendHost (atomically . writeTChan sendToComponent) componentJid toRoomPresences toJoinPartDebouncer
void $ forkIO $ roomPresences db toRoomPresences
@@ 1998,5 2025,5 @@ main = do
log "" "runComponent STARTING"
log "runComponent ENDED" =<< runComponent (Server componentJid host (PortNumber port)) secret
- (component db redis (UIO.lift . pushStatsd) backendHost did (cacheOOB (UIO.lift . pushStatsd) jingleStore jingleStoreURL) adhocBotIQReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
+ (component db redis (UIO.lift . pushStatsd) backendHost did (cacheOOB (UIO.lift . pushStatsd) jingleStore jingleStoreURL) sendIQ iqReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
_ -> log "ERROR" "Bad arguments"