~singpolyma/cheogram

db597fb13f1c5621b34f91ba11f4cbc5b5ee20f9 — Stephen Paul Weber 1 year, 4 months ago cd9bdf4 + ca9dc74
Merge branch 'fix-errors-in-adhoc'

* fix-errors-in-adhoc:
  IQManager should get both IQResult and IQError
  Never reply to an error
2 files changed, 45 insertions(+), 37 deletions(-)

M ConfigureDirectMessageRoute.hs
M Main.hs
M ConfigureDirectMessageRoute.hs => ConfigureDirectMessageRoute.hs +10 -7
@@ 21,7 21,7 @@ import Util

newtype SessionID = SessionID UUID deriving (Ord, Eq, Show)

main :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> IO (XMPP.IQ -> IO XMPP.IQ)
main :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> IO (XMPP.IQ -> IO (Maybe XMPP.IQ))
main getRouteJid setRouteJid = do
	stanzas <- newTQueueIO
	void $ forkIO $ iterateM_ (\sessions -> do


@@ 37,22 37,25 @@ main getRouteJid setRouteJid = do
			atomically $ readTMVar result
		)

processOneIQ :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, UTCTime), XMPP.IQ)
processOneIQ :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, UTCTime), Maybe XMPP.IQ)
processOneIQ getRouteJid setRouteJid sessions iq@(XMPP.IQ { XMPP.iqID = Just iqID, XMPP.iqFrom = Just from, XMPP.iqPayload = realPayload })
	| Just sid <- sessionIDFromText . snd =<< T.uncons =<< T.stripPrefix (s"ConfigureDirectMessageRoute") iqID,
          XMPP.iqType iq == XMPP.IQResult || XMPP.iqType iq == XMPP.IQError =
		lookupAndStepSession setRouteJid sessions sid iqID from payload
		(fmap Just) <$> lookupAndStepSession setRouteJid sessions sid iqID from payload
	| elementName payload /= s"{http://jabber.org/protocol/commands}command" ||
	  attributeText (s"node") payload /= Just nodeName = do
		log "ConfigureDirectMessageRoute.processOneIQ BAD INPUT" (elementName payload, attributeText (s"node") payload)
		return (sessions, iqError (Just iqID) (Just from) "cancel" "feature-not-implemented" Nothing)
		if XMPP.iqType iq == XMPP.IQError then
			return (sessions, Nothing)
		else
			return (sessions, Just $ iqError (Just iqID) (Just from) "cancel" "feature-not-implemented" Nothing)
	| Just sid <- sessionIDFromText =<< attributeText (s"sessionid") payload =
		lookupAndStepSession setRouteJid sessions sid iqID from payload
		(fmap Just) <$> lookupAndStepSession setRouteJid sessions sid iqID from payload
	| otherwise = do
		(sid, session) <- newSession
		now <- getCurrentTime
		existingRoute <- getRouteJid from
		return (Map.insert sid (session, now) sessions, stage1 existingRoute from iqID sid)
		return (Map.insert sid (session, now) sessions, Just $ stage1 existingRoute from iqID sid)
	where
	payload
		| Just p <- realPayload,


@@ 62,7 65,7 @@ processOneIQ getRouteJid setRouteJid sessions iq@(XMPP.IQ { XMPP.iqID = Just iqI
		| otherwise = fromMaybe (Element (s"no-payload") [] []) realPayload
processOneIQ _ _ sessions iq@(XMPP.IQ { XMPP.iqID = iqID, XMPP.iqFrom = from }) = do
	log "ConfigureDirectMessageRoute.processOneIQ BAD INPUT" iq
	return (sessions, iqError iqID from "cancel" "feature-not-implemented" Nothing)
	return (sessions, Just $ iqError iqID from "cancel" "feature-not-implemented" Nothing)

lookupAndStepSession :: (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> Session' (IO (Map SessionID (Session, UTCTime), XMPP.IQ))
lookupAndStepSession setRouteJid sessions sid iqID from payload

M Main.hs => Main.hs +35 -30
@@ 683,7 683,7 @@ data ComponentContext = ComponentContext {
	toRoomPresences :: TChan RoomPresences,
	toRejoinManager :: TChan RejoinManagerCommand,
	toJoinPartDebouncer :: TChan JoinPartDebounce,
	processDirectMessageRouteConfig :: IQ -> IO IQ,
	processDirectMessageRouteConfig :: IQ -> IO (Maybe IQ),
	componentJid :: JID,
	sendIQ :: IQ -> UIO (STM (Maybe IQ))
}


@@ 799,42 799,46 @@ componentStanza (ComponentContext { registrationJids, processDirectMessageRouteC
				iqFrom = Just asFrom,
				iqPayload = Just payload
			}
		let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ)

		let subscribe = if attributeText (s"action") payload /= Just (s"complete") then [] else [
				mkStanzaRec $ (emptyPresence PresenceSubscribe) {
					presenceTo = Just asFrom,
					presenceFrom = Just componentJid,
					presencePayloads = [
						Element (s"{jabber:component:accept}status") [] [
							NodeContent $ ContentText $ s"Add this contact and then you can SMS by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs."
		fmap (fromMaybe []) $ forM replyIQ $ \replyIQ -> do
		--(\f -> maybe (return []) f replyIQ) $ \replyIQ -> do
			let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ)

			let subscribe = if attributeText (s"action") payload /= Just (s"complete") then [] else [
					mkStanzaRec $ (emptyPresence PresenceSubscribe) {
						presenceTo = Just asFrom,
						presenceFrom = Just componentJid,
						presencePayloads = [
							Element (s"{jabber:component:accept}status") [] [
								NodeContent $ ContentText $ s"Add this contact and then you can SMS by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs."
							]
						]
					]
				}
			]
					}
				]

		return $ subscribe ++ [mkStanzaRec $ replyIQ {
			iqTo = if iqTo replyIQ == Just asFrom then Just from else iqTo replyIQ,
			iqID = if iqType replyIQ == IQResult then iqID replyIQ else Just $ fromString $ show (formatJID from, formatJID asFrom, iqID replyIQ),
			iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
		}]
			return $ subscribe ++ [mkStanzaRec $ replyIQ {
				iqTo = if iqTo replyIQ == Just asFrom then Just from else iqTo replyIQ,
				iqID = if iqType replyIQ == IQResult then iqID replyIQ else Just $ fromString $ show (formatJID from, formatJID asFrom, iqID replyIQ),
				iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
			}]
componentStanza (ComponentContext { processDirectMessageRouteConfig, componentJid }) (ReceivedIQ iq@(IQ { iqTo = Just to }))
	| fmap strResource (jidResource to) == Just (s"CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName),
	  Just (fwdBy, onBehalf, iqId) <- readZ . T.unpack =<< iqID iq = do
		replyIQ <- processDirectMessageRouteConfig (iq { iqID = iqId })
		let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ)
		return [mkStanzaRec $ replyIQ {
			iqTo = if fmap bareTxt (iqTo replyIQ) == Just onBehalf then parseJID fwdBy else iqTo replyIQ,
			iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
		}]
		fmap (fromMaybe []) $ forM replyIQ $ \replyIQ -> do
			let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ)
			return [mkStanzaRec $ replyIQ {
				iqTo = if fmap bareTxt (iqTo replyIQ) == Just onBehalf then parseJID fwdBy else iqTo replyIQ,
				iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
			}]
componentStanza (ComponentContext { processDirectMessageRouteConfig, componentJid }) (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = payload }))
	| (jidNode to == Nothing && fmap elementName payload == Just (s"{http://jabber.org/protocol/commands}command") && (attributeText (s"node") =<< payload) == Just ConfigureDirectMessageRoute.nodeName) ||
	  fmap strResource (jidResource to) == Just (s"CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName) = do
		replyIQ <- processDirectMessageRouteConfig iq
		let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ)
		return [mkStanzaRec $ replyIQ {
			iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
		}]
		fmap (fromMaybe []) $ forM replyIQ $ \replyIQ -> do
			let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ)
			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",


@@ 1241,9 1245,10 @@ component db redis pushStatsd backendHost did cacheOOB sendIQ iqReceiver adhocBo
					Redis.hset (encodeUtf8 $ cheogramBareJid) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
			_ -> 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) `elem` map Just [s"adhocbot", s"IQMANAGER"] ->
				iqReceiver iq
			(_, Just to, _, _, ReceivedIQ iq@(IQ { iqType = typ }))
				| typ `elem` [IQResult, IQError],
				  (strResource <$> jidResource to) `elem` map Just [s"adhocbot", s"IQMANAGER"] ->
					iqReceiver iq
			(Just from, Just to, _, _, _)
				| strDomain (jidDomain from) == backendHost,
				  to == componentJid ->