~singpolyma/cheogram

dc7d0c198fa2c12bf4accc6ead408869809c3c02 — Stephen Paul Weber 5 years ago 5682f1b
Pass proxied stanzas from 1:1 route back through
3 files changed, 137 insertions(+), 76 deletions(-)

M Main.hs
M Util.hs
M cheogram.cabal
M Main.hs => Main.hs +100 -62
@@ 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


M Util.hs => Util.hs +36 -14
@@ 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

M cheogram.cabal => cheogram.cabal +1 -0
@@ 26,6 26,7 @@ executable cheogram
        build-depends:
                base == 4.*,
                basic-prelude <= 0.3.5.0,
                attoparsec,
                case-insensitive,
                containers,
                errors < 2.0.0,