From 6ee74440bdaf8ad03f562eb4278a1f7d852703a2 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Sat, 25 Feb 2017 16:03:58 -0500 Subject: [PATCH] Pass through presence at all --- Main.hs | 85 +++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 67 insertions(+), 18 deletions(-) diff --git a/Main.hs b/Main.hs index 388da5d..8e2d3cc 100644 --- a/Main.hs +++ b/Main.hs @@ -60,7 +60,7 @@ getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromSt queryDisco to from = do uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID - return $ [mkStanzaRec $ (emptyIQ IQGet) { + return [mkStanzaRec $ (emptyIQ IQGet) { iqTo = Just to, iqFrom = Just from, iqID = uuid, @@ -149,12 +149,35 @@ cheogramAvailable from to = Element (s"{http://jabber.org/protocol/caps}c") [ (s"{http://jabber.org/protocol/caps}hash", [ContentText $ fromString "sha-1"]), (s"{http://jabber.org/protocol/caps}node", [ContentText $ fromString "xmpp:cheogram.com"]), - -- gateway/sms//Cheogram SMS Gateway + let routeTo = fromMaybe componentJid $ parseJID $ (fromMaybe mempty $ strNode <$> jidNode smsJid) ++ s"@" ++ route in + queryDisco routeTo routeFrom + _ -> return [mkStanzaRec $ telAvailable to from []] + where + maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/query-then-send-presence" + componentMessage _ componentJid (m@Message { messageType = MessageError }) _ _ _ smsJid body = do log "MESSAGE ERROR" m return [mkStanzaRec $ m { messageTo = Just smsJid, messageFrom = Just componentJid }] @@ -518,7 +541,7 @@ componentStanza db (Just smsJid) toRoomPresences toRejoinManager toJoinPartDebou log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads) handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable) componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do - log "SUBSCRIBE" (from, to) + log "SUBSCRIBE GATEWAY" (from, to) return [ mkStanzaRec $ (emptyPresence PresenceSubscribed) { presenceTo = Just from, @@ -530,9 +553,25 @@ componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = Prese }, mkStanzaRec $ cheogramAvailable to from ] +componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do + log "SUBSCRIBE TEL" (from, to) + stanzas <- routeDiscoOrPresenceReply db componentJid from to smsJid + return $ [ + mkStanzaRec $ (emptyPresence PresenceSubscribed) { + presenceTo = Just from, + presenceFrom = Just to + }, + mkStanzaRec $ (emptyPresence PresenceSubscribe) { + presenceTo = Just from, + presenceFrom = Just to + } + ] ++ stanzas componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do log "RESPOND TO PROBES" (from, to) return [mkStanzaRec $ cheogramAvailable to from] +componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do + log "RESPOND TO TEL PROBES" smsJid + routeDiscoOrPresenceReply db componentJid from to smsJid componentStanza _ _ _ _ _ processDirectMessageRouteConfig componentJid (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = payload })) | (jidNode to == Nothing && fmap elementName payload == Just (s"{http://jabber.org/protocol/commands}command")) || fmap strResource (jidResource to) == Just ConfigureDirectMessageRoute.nodeName = do @@ -560,7 +599,7 @@ componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFro NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}identity") [ (fromString "{http://jabber.org/protocol/disco#info}category", [ContentText $ fromString "gateway"]), (fromString "{http://jabber.org/protocol/disco#info}type", [ContentText $ fromString "sms"]), - (fromString "{http://jabber.org/protocol/disco#info}name", [ContentText $ fromString "Cheogram SMS Gateway"]) + (fromString "{http://jabber.org/protocol/disco#info}name", [ContentText $ fromString "Cheogram"]) ] [], NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [ (fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "jabber:iq:gateway"]) @@ -599,18 +638,18 @@ componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just fr iqTo = Just from, iqFrom = Just to, iqID = id, - iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] + iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] $ [ + NodeElement $ Element (s"{http://jabber.org/protocol/disco#info}identity") [ + (s"{http://jabber.org/protocol/disco#info}category", [ContentText $ s"client"]), + (s"{http://jabber.org/protocol/disco#info}type", [ContentText $ s"sms"]), + (s"{http://jabber.org/protocol/disco#info}name", [ContentText $ s"Cheogram"]) + ] [] + ] ++ map (\var -> NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [ (fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "http://jabber.org/protocol/muc"]) - ] [], - NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [ - (fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "jabber:x:conference"]) - ] [], - NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [ - (fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "urn:xmpp:ping"]) ] [] - ] + ) telDiscoFeatures }] componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) | [query] <- isNamed (fromString "{jabber:iq:gateway}query") p, @@ -691,7 +730,7 @@ componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) | [query] <- isNamed (fromString "{http://jabber.org/protocol/muc#owner}query") p, [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query = do - log "DISCO RESULT" (from, to, p) + log "MUC DISCO RESULT" (from, to, p) uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID let fullid = if fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id then "CHEOGRAMCREATE%" <> uuid else uuid return [mkStanzaRec $ (emptyIQ IQSet) { @@ -713,9 +752,18 @@ componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType fmap (((mkStanzaRec $ mkSMS componentJid smsJid (mconcat [fromString "* You have created ", bareTxt from])):) . concat . toList) $ forM (parseJID $ bareTxt to <> fromString "/create") $ queryDisco from -componentStanza db _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p })) - | Just _ <- strNode <$> jidNode to, - [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do +componentStanza db _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from, iqPayload = Just p })) + | fmap strResource (jidResource to) == Just (s"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 + log "DISCO RESULT, NOW SEND PRESENCE" (from, to, routeFrom, routeTo) + return [ + mkStanzaRec $ telAvailable routeFrom routeTo $ 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 log "DISCO RESULT" (from, to, p) let vars = mapMaybe (attributeText (fromString "var")) $ isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query @@ -791,7 +839,8 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt _ -> log "backend no match" stanza (Just from, Just to, Nothing, Just localpart) - | fmap strResource (jidResource to) /= Just ConfigureDirectMessageRoute.nodeName -> do + | fmap strResource (jidResource to) /= Just ConfigureDirectMessageRoute.nodeName, + fmap strResource (jidResource to) /= Just (s"query-then-send-presence") -> do let toResourceSuffix = maybe mempty (s"/"++) (strResource <$> jidResource to) maybeRoute <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0direct-message-route") case (fmap fromString maybeRoute, parseJID (unescapeJid localpart ++ toResourceSuffix), mapToComponent from) of -- 2.45.2