From dc7d0c198fa2c12bf4accc6ead408869809c3c02 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Thu, 16 Feb 2017 21:50:48 -0500 Subject: [PATCH] Pass proxied stanzas from 1:1 route back through --- Main.hs | 162 ++++++++++++++++++++++++++++++------------------- Util.hs | 50 ++++++++++----- cheogram.cabal | 1 + 3 files changed, 137 insertions(+), 76 deletions(-) diff --git a/Main.hs b/Main.hs index 1b52304..d01171e 100644 --- a/Main.hs +++ b/Main.hs @@ -476,62 +476,30 @@ componentStanza _ _ _ _ _ _ _ (ReceivedMessage (m@Message { messageTo = Just to, not $ null $ code "104" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do log "CODE104" (to, from) queryDisco from to -componentStanza db mapToBackend _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) - | Just smsJid <- mapToBackend to = do - log "RECEIVEDMESSAGE" m - existingRoom <- tcGetJID db to "joined" - componentMessage db componentJid m existingRoom (bareTxt from) resourceFrom smsJid $ - getBody "jabber:component:accept" m - | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to = do - log "MESSAGE INVALID JID" m - return [mkStanzaRec $ m { - messageFrom = Just to, - messageTo = Just from, - messageType = MessageError, - messagePayloads = messagePayloads m <> [ - Element (fromString "{jabber:component:accept}error") - [(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])] - [ - NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}gone") [] - [NodeContent $ ContentText $ formatJID jid], - NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") - [(fromString "xml:lang", [ContentText $ fromString "en"])] - [NodeContent $ ContentText $ fromString "JID must include country code: " <> formatJID jid] - ] - ] - }] - | otherwise = do - log "MESSAGE UNKNOWN JID" m - return [mkStanzaRec $ m { - messageFrom = Just to, - messageTo = Just from, - messageType = MessageError, - messagePayloads = messagePayloads m <> [ - Element (fromString "{jabber:component:accept}error") - [(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])] - [NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found") [] []] - ] - }] +componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) = do + log "RECEIVEDMESSAGE" m + existingRoom <- tcGetJID db to "joined" + componentMessage db componentJid m existingRoom (bareTxt from) resourceFrom smsJid $ + getBody "jabber:component:accept" m where resourceFrom = strResource <$> jidResource from -componentStanza _ mapToBackend _ toRejoinManager _ _ componentJid (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id })) +componentStanza _ (Just smsJid) _ toRejoinManager _ _ componentJid (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id })) | fromString "CHEOGRAMREJOIN%" `T.isPrefixOf` id = do log "FAILED TO REJOIN, try again in 10s" p void $ forkIO $ threadDelay 10000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to) return [] - | Just smsJid <- mapToBackend to = do + | otherwise = do log "FAILED TO JOIN" p let errorText = maybe mempty (mconcat . (fromString "\n":) . elementText) $ listToMaybe $ isNamed (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") =<< elementChildren =<< isNamed (fromString "{jabber:component:accept}error") =<< presencePayloads p return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* Failed to join " <> bareTxt from <> errorText)] -componentStanza db mapToBackend toRoomPresences toRejoinManager toJoinPartDebouncer _ componentJid (ReceivedPresence (Presence { +componentStanza db (Just smsJid) toRoomPresences toRejoinManager toJoinPartDebouncer _ componentJid (ReceivedPresence (Presence { presenceType = typ, presenceFrom = Just from, presenceTo = Just to, presencePayloads = payloads - })) | typ `elem` [PresenceAvailable, PresenceUnavailable], - Just smsJid <- mapToBackend to = do + })) | typ `elem` [PresenceAvailable, PresenceUnavailable] = do existingRoom <- tcGetJID db to "joined" log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads) handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable) @@ -714,10 +682,9 @@ componentStanza _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQErro log "PING ERROR RESULT" from atomically $ writeTChan toRejoinManager (PingError from) return [] -componentStanza _ mapToBackend _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) - | Just smsJid <- mapToBackend to = do - log "IQ ERROR" iq - return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "Error while querying or configuring " <> formatJID from)] +componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) = do + log "IQ ERROR" iq + return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "Error while querying or configuring " <> formatJID from)] 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 @@ -737,9 +704,8 @@ componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just form { elementAttributes = [(fromString "{jabber:x:data}type", [ContentText $ fromString "submit"])] } ] }] -componentStanza _ mapToBackend _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) - | Just smsJid <- mapToBackend to, - fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id = do +componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) + | fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id = do log "CHEOGRAMCREATE RESULT YOU HAVE CREATED" (from, to, iq) fmap (((mkStanzaRec $ mkSMS componentJid smsJid (mconcat [fromString "* You have created ", bareTxt from])):) . concat . toList) $ forM (parseJID $ bareTxt to <> fromString "/create") $ @@ -807,33 +773,105 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC putStanza stanza flip catchError (\e -> liftIO (log "component part 2 EXCEPTION" e >> killThread thread)) $ forever $ do - s <- getStanza - log "COMPONENT IN" s - liftIO $ case s of - (ReceivedMessage m@(Message { messageFrom = Just from, messageTo = Just to })) + stanza <- getStanza + log "COMPONENT IN" stanza + liftIO $ case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza)) of + (Just from, Just to, _, _) | strDomain (jidDomain from) == backendHost, to == componentJid -> - case (messageType m, getBody "jabber:component:accept" m, mapToComponent from) of - (MessageError, _, _) -> log "backend error" s - (_, Just txt, Just cheoJid) -> - mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt - _ -> - mapM_ sendToComponent =<< componentStanza db (mapToBackend backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid s + case stanza of + (ReceivedMessage m@(Message { messageType = MessageError })) -> + log "backend error" stanza + (ReceivedMessage m) + | Just txt <- getBody "jabber:component:accept" m, + Just cheoJid <- mapToComponent from -> + 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 + 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 + (Just route, Just routeTo, Just componentFrom) | route == strDomain (jidDomain from) -> do + log "FROM DIRECT ROUTE" stanza + sendToComponent $ receivedStanzaFromTo componentFrom routeTo stanza + _ | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to -> do + log "MESSAGE INVALID JID" stanza + sendToComponent $ stanzaError stanza $ + Element (fromString "{jabber:component:accept}error") + [(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])] + [ + NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}gone") [] + [NodeContent $ ContentText $ formatJID jid], + NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") + [(fromString "xml:lang", [ContentText $ fromString "en"])] + [NodeContent $ ContentText $ fromString "JID must include country code: " <> formatJID jid] + ] + | otherwise -> do + log "MESSAGE UNKNOWN JID" stanza + sendToComponent $ stanzaError stanza $ + Element (fromString "{jabber:component:accept}error") + [(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])] + [NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found") [] []] + (_, _, backendTo, _) -> + mapM_ sendToComponent =<< componentStanza db backendTo toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza where mapToComponent = mapToBackend (formatJID componentJid) sendToComponent = atomically . writeTChan toComponent + stanzaError (ReceivedMessage m) errorPayload = + mkStanzaRec $ m { + messageFrom = messageTo m, + messageTo = messageFrom m, + messageType = MessageError, + messagePayloads = messagePayloads m ++ [errorPayload] + } + stanzaError (ReceivedPresence p) errorPayload = + mkStanzaRec $ p { + presenceFrom = presenceTo p, + presenceTo = presenceFrom p, + presenceType = PresenceError, + presencePayloads = presencePayloads p ++ [errorPayload] + } + stanzaError (ReceivedIQ iq) errorPayload = + mkStanzaRec $ iq { + iqFrom = iqTo iq, + iqTo = iqFrom iq, + iqType = IQError, + iqPayload = Just errorPayload + } + + receivedStanzaFromTo from to (ReceivedMessage m) = mkStanzaRec $ m { + messageFrom = Just from, + messageTo = Just to + } + receivedStanzaFromTo from to (ReceivedPresence p) = mkStanzaRec $ p { + presenceFrom = Just from, + presenceTo = Just to + } + receivedStanzaFromTo from to (ReceivedIQ iq) = mkStanzaRec $ iq { + iqFrom = Just from, + iqTo = Just to + } + + receivedStanza (ReceivedMessage m) = mkStanzaRec m + receivedStanza (ReceivedPresence p) = mkStanzaRec p + receivedStanza (ReceivedIQ iq) = mkStanzaRec iq + mapToBackend backendHost jid | Just localpart <- strNode <$> jidNode jid, Just ('+', tel) <- T.uncons localpart, T.all isDigit tel = parseJID (localpart <> fromString "@" <> backendHost) | otherwise = Nothing -normalizeTel tel - | not $ all isDigit $ T.unpack tel = Nothing - | T.length tel == 10 = Just $ T.cons '1' tel - | T.length tel == 11, fromString "1" `T.isPrefixOf` tel = Just tel +normalizeTel fullTel + | Just ('+',e164) <- T.uncons fullTel, + T.all isDigit e164 = Just fullTel + | T.length tel == 10 = Just (s"+1" ++ tel) + | T.length tel == 11, s"1" `T.isPrefixOf` tel = Just (T.cons '+' tel) | otherwise = Nothing + where + tel = T.filter isDigit fullTel telToJid tel host = parseJID =<< (<> fromString "@" <> host) <$> normalizeTel tel diff --git a/Util.hs b/Util.hs index ab09ac2..c7caaf6 100644 --- a/Util.hs +++ b/Util.hs @@ -2,11 +2,13 @@ module Util where import Prelude () import BasicPrelude +import Control.Applicative (many) import Data.Time (getCurrentTime) import Data.XML.Types (Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText) import qualified Data.Text as T import qualified Network.Protocol.XMPP as XMPP +import qualified Data.Attoparsec.Text as Atto log :: (Show a, MonadIO m) => String -> a -> m () log tag x = liftIO $ do @@ -17,20 +19,40 @@ s :: (IsString a) => String -> a s = fromString escapeJid :: Text -> Text -escapeJid txt = T.concatMap (\char -> - case char of - ' ' -> s"\\20" - '"' -> s"\\22" - '&' -> s"\\26" - '\'' -> s"\\27" - '/' -> s"\\2f" - ':' -> s"\\3a" - '<' -> s"\\3c" - '>' -> s"\\3e" - '@' -> s"\\40" - '\\' -> s"\\5c" - c -> T.singleton c - ) txt +escapeJid txt = mconcat result + where + Right result = Atto.parseOnly (many ( + slashEscape <|> + replace ' ' "\\20" <|> + replace '"' "\\22" <|> + replace '&' "\\26" <|> + replace '\'' "\\27" <|> + replace '/' "\\2f" <|> + replace ':' "\\3a" <|> + replace '<' "\\3c" <|> + replace '>' "\\3e" <|> + replace '@' "\\40" <|> + fmap T.singleton Atto.anyChar + ) <* Atto.endOfInput) txt + replace c str = Atto.char c *> pure (fromString str) + -- XEP-0106 says to only escape \ when absolutely necessary + slashEscape = + fmap (s"\\5c"++) $ + Atto.char '\\' *> Atto.choice escapes + escapes = map (Atto.string . fromString) [ + "20", "22", "26", "27", "2f", "3a", "3c", "3e", "40", "5c" + ] + +unescapeJid :: Text -> Text +unescapeJid txt = fromString result + where + Right result = Atto.parseOnly (many ( + (Atto.char '\\' *> Atto.choice unescapes) <|> + Atto.anyChar + ) <* Atto.endOfInput) txt + unescapes = map (\(str, c) -> Atto.string (fromString str) *> pure c) [ + ("20", ' '), ("22", '"'), ("26", '&'), ("27", '\''), ("2f", '/'), ("3a", ':'), ("3c", '<'), ("3e", '>'), ("40", '@'), ("5c", '\\') + ] bareTxt (XMPP.JID (Just node) domain _) = mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain] bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain diff --git a/cheogram.cabal b/cheogram.cabal index 11b2d53..c163130 100644 --- a/cheogram.cabal +++ b/cheogram.cabal @@ -26,6 +26,7 @@ executable cheogram build-depends: base == 4.*, basic-prelude <= 0.3.5.0, + attoparsec, case-insensitive, containers, errors < 2.0.0, -- 2.38.5