2 files changed, 45 insertions(+), 37 deletions(-)

M ConfigureDirectMessageRoute.hs
M Main.hs

@@ 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

@@ 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 ->