From 645c88f288bf7c9786d29507c2ad66a035e8002c Mon Sep 17 00:00:00 2001
From: Christopher Vollick <0@psycoti.ca>
Date: Thu, 21 Jan 2021 15:40:35 -0500
Subject: [PATCH] AdHoc Bot Forms

Before this when a user got back a form it was considered an error. Only
commands that returned a note could be executed.
Now, though, we see the form and try to handle it as a series of chat questions
asked to the people. This is only the first version of the technique, though,
so it has some pretty strong limitations.

First, it only supports lists because that's all the test flow I pulled out of
the spec had in it. There are obviously other field types that this will need
to support to be considered finished.

Second, it only goes forwards. There's no cancel, no returning to previous
questions, etc. It also waits forever (well, until the next restart) for the
user to finish, occupying memory in the session holder until then. We could
also maybe ask confirmation before crossing from one form to another, from the
server's perspective, since there's no guarantee that changes made aren't
immediately applied, rather than waiting for the end. At the very least we
should have timeouts and cancelling though.

Third, there's no error handling at all. It just takes things and assumes
success. That should maybe go along with cancellation, at least, but handling
it with some kind of error message and retry may be nice, if the standard and
the server command accepts it.
---
 Adhoc.hs       | 220 +++++++++++++++++++++++++++++++++++++++++++++++++
 Main.hs        | 144 +++++---------------------------
 StanzaRec.hs   |  20 +++++
 Util.hs        |  14 +++-
 cheogram.cabal |   2 +-
 5 files changed, 276 insertions(+), 124 deletions(-)
 create mode 100644 Adhoc.hs
 create mode 100644 StanzaRec.hs

diff --git a/Adhoc.hs b/Adhoc.hs
new file mode 100644
index 0000000..d92ee1e
--- /dev/null
+++ b/Adhoc.hs
@@ -0,0 +1,220 @@
+module Adhoc(adhocBotSession, commandList, queryCommandList) where
+
+import Prelude ()
+import BasicPrelude hiding (log)
+import Control.Concurrent.STM
+import Control.Error (hush)
+import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Content(ContentText), isNamed, elementText, elementChildren, attributeText)
+
+import Network.Protocol.XMPP (JID(..), parseJID, formatJID, IQ(..), IQType(..), emptyIQ, Message(..))
+import qualified Network.Protocol.XMPP as XMPP
+
+import qualified Data.Attoparsec.Text as Atto
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.UUID as UUID ( toString )
+import qualified Data.UUID.V1 as UUID ( nextUUID )
+import qualified Database.TokyoCabinet as TC
+import qualified UnexceptionalIO as UIO
+
+import StanzaRec
+import UniquePrefix
+import Util
+import qualified ConfigureDirectMessageRoute
+
+botHelp :: IQ -> Maybe Message
+botHelp (IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payload }) =
+	Just $ mkSMS from to $ (s"Help:\n\t") ++ intercalate (s"\n\t") (map (\item ->
+		fromMaybe mempty (attributeText (s"node") item) ++ s": " ++
+		fromMaybe mempty (attributeText (s"name") item)
+	) items)
+	where
+	items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren payload
+botHelp _ = Nothing
+
+commandList :: JID -> Maybe Text -> JID -> JID -> [Element] -> IQ
+commandList componentJid qid from to extras =
+	(emptyIQ IQResult) {
+		iqTo = Just to,
+		iqFrom = Just from,
+		iqID = qid,
+		iqPayload = Just $ Element (s"{http://jabber.org/protocol/disco#items}query")
+			[(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])]
+			([
+				NodeElement $ Element (s"{http://jabber.org/protocol/disco#items}item") [
+						(s"jid", [ContentText $ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName]),
+						(s"node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
+						(s"name", [ContentText $ s"Configure direct message route"])
+				] []
+			] ++ extraItems)
+	}
+	where
+	extraItems = map (\el ->
+			NodeElement $ el {
+				elementAttributes = map (\(aname, acontent) ->
+					if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
+						(aname, [ContentText $ formatJID componentJid])
+					else
+						(aname, acontent)
+				) (elementAttributes el)
+			}
+		) extras
+
+queryCommandList' :: JID -> JID -> IQ
+queryCommandList' to from =
+	(emptyIQ IQGet) {
+		iqTo = Just to,
+		iqFrom = Just from,
+		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [
+			(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])
+		] []
+	}
+
+queryCommandList :: JID -> JID -> IO [StanzaRec]
+queryCommandList to from = do
+	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
+	return [mkStanzaRec $ (queryCommandList' to from) {iqID = uuid}]
+
+
+untilParse :: (UIO.Unexceptional m) => STM Message -> STM () -> Atto.Parser b -> m b
+untilParse getText onFail parser = do
+	text <- atomicUIO $ (fromMaybe mempty . getBody "jabber:component:accept") <$> getText
+	case Atto.parseOnly parser text of
+		Right v -> return v
+		Left _ -> do
+			atomicUIO onFail
+			untilParse getText onFail parser
+
+adhocBotAnswerListMulti :: (UIO.Unexceptional m) => JID -> (XMPP.Message -> STM ()) -> STM XMPP.Message -> JID -> Element -> m [Element]
+adhocBotAnswerListMulti componentJid sendMessage getMessage from field = do
+	case attributeText (s"var") field of
+		Just var -> do
+			let label = fromMaybe (s"Select") $ attributeText (s"label") field
+			let options = zip [1..] $ isNamed(s"{jabber:x:data}option") =<< elementChildren field
+			let optionsText = fmap (\(n, v) -> tshow n <> s". " <> optionText v) options
+			atomicUIO $ sendMessage $ mkSMS componentJid from $ unlines $ [label <> s": (enter numbers with commas or spaces between them)"] <> optionsText
+			values <- untilParse getMessage (sendMessage $ mkSMS componentJid from helperText) parser
+			let selectedOptions = fmap snd $ filter (\(x, _) -> x `elem` values) options
+			return [Element (s"{jabber:x:data}field") [(s"var", [ContentText var])] $ flip fmap selectedOptions $ \option ->
+						NodeElement $ Element (s"{jabber:x:data}value") [] [NodeContent $ ContentText $ optionValue option]
+				]
+		_ -> log "ADHOC BOT FIELD WITHOUT VAR" field >> return []
+	where
+	parser = Atto.skipMany Atto.space *> Atto.sepBy (Atto.decimal :: Atto.Parser Int) (Atto.skipMany $ Atto.choice [Atto.space, Atto.char ',']) <* Atto.skipMany Atto.space <* Atto.endOfInput
+	helperText = s"I didn't understand your answer. Please send the numbers you want, separated by commas or spaces like \"1, 3\" or \"1 3\". Blank (or just spaces) to pick nothing."
+
+adhocBotAnswerListSingle :: (UIO.Unexceptional m) => JID -> (XMPP.Message -> STM ()) -> STM XMPP.Message -> JID -> Element -> m [Element]
+adhocBotAnswerListSingle componentJid sendMessage getMessage from field = do
+	case attributeText (s"var") field of
+		Just var -> do
+			let label = fromMaybe (s"Select") $ attributeText (s"label") field
+			let options = zip [1..] $ isNamed(s"{jabber:x:data}option") =<< elementChildren field
+			let optionsText = fmap (\(n, v) -> tshow n <> s". " <> optionText v) options
+			atomicUIO $ sendMessage $ mkSMS componentJid from $ unlines $ [label <> s": (enter one number)"] <> optionsText
+			value <- untilParse getMessage (sendMessage $ mkSMS componentJid from helperText) (Atto.skipMany Atto.space *> (Atto.decimal :: Atto.Parser Int) <* Atto.skipMany Atto.space)
+			let maybeOption = fmap snd $ find (\(x, _) -> x == value) options
+			case maybeOption of
+				Just option -> return [Element (s"{jabber:x:data}field") [(s"var", [ContentText var])] [
+						NodeElement $ Element (s"{jabber:x:data}value") [] [NodeContent $ ContentText $ optionValue option]
+					]]
+				Nothing -> do
+					atomicUIO $ sendMessage $ mkSMS componentJid from $ s"Please pick one of the given options"
+					adhocBotAnswerListSingle componentJid sendMessage getMessage from field
+		_ -> log "ADHOC BOT FIELD WITHOUT VAR" field >> return []
+	where
+	helperText = s"I didn't understand your answer. Please just send the number of the one item you want to pick, like \"1\""
+
+adhocBotAnswerForm :: (UIO.Unexceptional m) => JID -> (XMPP.Message -> STM ()) -> STM XMPP.Message -> JID -> Element -> m Element
+adhocBotAnswerForm componentJid sendMessage getMessage from form = do
+	fields <- forM (elementChildren form) $ \field -> do
+		case field of
+			_
+				| elementName field == s"{jabber:x:data}instructions" -> atomicUIO (sendMessage $ mkSMS componentJid from $ mconcat $ elementText field) >> return []
+			_
+				| elementName field == s"{jabber:x:data}field",
+				  attributeText (s"type") field == Just (s"list-single") ->
+					adhocBotAnswerListSingle componentJid sendMessage getMessage from field
+			_
+				| elementName field == s"{jabber:x:data}field",
+				  attributeText (s"type") field == Just (s"list-multi") ->
+					adhocBotAnswerListMulti componentJid sendMessage getMessage from field
+			-- XXX: Should I pass a logger in here?
+			c -> fromIO_ (print c) >> return []
+	return $ Element (s"{jabber:x:data}x") [(s"type", [ContentText $ s"submit"])] $ NodeElement <$> mconcat fields
+
+optionText :: Element -> Text
+optionText element = fromMaybe (optionValue element) $ attributeText (s"label") element
+
+optionValue :: Element -> Text
+optionValue element = mconcat $ elementText =<< isNamed(s"{jabber:x:data}value") =<< elementChildren element
+
+adhocBotRunCommand :: (UIO.Unexceptional m) => JID -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> JID -> Text -> [Element] -> m ()
+adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body cmdEls = do
+	let (nodes, cmds) = unzip $ mapMaybe (\el -> (,) <$> attributeText (s"node") el <*> pure el) cmdEls
+	case snd <$> find (\(prefixes, _) -> Set.member body prefixes) (zip (uniquePrefix nodes) cmds) of
+		Just cmd -> do
+			let cmdIQ = (emptyIQ IQSet) {
+				iqFrom = Just routeFrom,
+				iqTo = parseJID =<< attributeText (s"jid") cmd,
+				iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText $ fromMaybe mempty $ attributeText (s"node") cmd])] []
+			}
+			sendAndRespondTo cmdIQ
+		Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs.  Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
+	where
+	sendAndRespondTo cmdIQ = do
+		mcmdResult <- atomicUIO =<< UIO.lift (sendIQ cmdIQ)
+		case mcmdResult of
+			Just resultIQ
+				| IQResult == iqType resultIQ,
+				  Just payload <- iqPayload resultIQ,
+				  [note] <- isNamed (s"{http://jabber.org/protocol/commands}note") =<< elementChildren payload ->
+					atomicUIO $ sendMessage $ mkSMS componentJid from $ mconcat $ elementText note
+				| IQResult == iqType resultIQ,
+				  Just payload <- iqPayload resultIQ,
+				  Just sessionid <- attributeText (s"sessionid") payload,
+				  [form] <- isNamed (s"{jabber:x:data}x") =<< elementChildren payload -> do
+					returnForm <- adhocBotAnswerForm componentJid sendMessage getMessage from form
+					let actions = listToMaybe $ isNamed(s"{http://jabber.org/protocol/commands}actions") =<< elementChildren payload
+					-- The standard says if actions is present, with no "execute" attribute, that the default is "next"
+					-- But if there is no actions, the default is "execute"
+					let defaultAction = maybe (s"execute") (fromMaybe (s"next") . attributeText (s"execute")) actions
+					let cmdIQ' = (emptyIQ IQSet) {
+						iqFrom = Just routeFrom,
+						iqTo = iqFrom resultIQ,
+						iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText $ fromMaybe mempty $ attributeText (s"node") payload]), (s"sessionid", [ContentText sessionid]), (s"action", [ContentText defaultAction])] [NodeElement returnForm]
+					}
+					sendAndRespondTo cmdIQ'
+				| otherwise -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command error")
+			Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command timed out")
+
+adhocBotSession :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> XMPP.Message-> m ()
+adhocBotSession db componentJid sendMessage sendIQ getMessage message@(XMPP.Message { XMPP.messageFrom = Just from })
+	| Just body <- getBody "jabber:component:accept" message,
+	  body == s"help" = do
+		maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
+		case parseJID =<< fmap fromString maybeRoute of
+			Just route -> do
+				mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
+				let helpMessage = botHelp $ commandList componentJid Nothing componentJid from $
+					isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren =<< maybeToList (XMPP.iqPayload =<< mfilter ((== XMPP.IQResult) . XMPP.iqType) mreply)
+				case helpMessage of
+					Just msg -> atomicUIO $ sendMessage msg
+					Nothing -> log "INVALID HELP MESSAGE" mreply
+			Nothing ->
+				case botHelp $ commandList componentJid Nothing componentJid from [] of
+					Just msg -> atomicUIO $ sendMessage msg
+					Nothing -> log "INVALID HELP MESSAGE" ()
+	| Just body <- getBody "jabber:component:accept" message = do
+		maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
+		case parseJID =<< fmap fromString maybeRoute of
+			Just route -> do
+				mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
+				case iqPayload =<< mfilter ((==IQResult) . iqType) mreply of
+					Just reply -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body (elementChildren reply)
+					Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body (elementChildren =<< maybeToList (iqPayload $ commandList componentJid Nothing componentJid from []))
+			Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body (elementChildren =<< maybeToList (iqPayload $ commandList componentJid Nothing componentJid from []))
+	| otherwise =
+		atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs.  Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
+	where
+	Just routeFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/adhocbot"
+adhocBotSession _ _ _ _ _ m = log "BAD ADHOC BOT MESSAGE" m
diff --git a/Main.hs b/Main.hs
index 24aa851..2bd2a5b 100644
--- a/Main.hs
+++ b/Main.hs
@@ -10,7 +10,7 @@ import Control.Concurrent.STM
 import Data.Foldable (forM_, mapM_, toList)
 import Data.Traversable (forM, mapM)
 import System.Environment (getArgs)
-import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ, hush)
+import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ)
 import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
 import Network (PortID(PortNumber))
 import Network.URI (parseURI, uriPath)
@@ -25,7 +25,6 @@ import qualified Network.StatsD as StatsD
 import "monads-tf" Control.Monad.Error (catchError) -- ick
 import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText, attributeContent, hasAttribute, nameNamespace)
 import qualified UnexceptionalIO as UIO
-import qualified Data.Set as Set
 import qualified Dhall
 import qualified Dhall.Core as Dhall hiding (Decoder)
 import qualified Jingle
@@ -44,33 +43,17 @@ import qualified Database.TokyoCabinet as TC
 import qualified Database.Redis as Redis
 import qualified Text.Regex.PCRE.Light as PCRE
 import Network.Protocol.XMPP as XMPP -- should import qualified
-import Network.Protocol.XMPP.Internal -- should import qualified
 
 import Util
-import UniquePrefix
 import IQManager
 import qualified RedisURL
 import qualified ConfigureDirectMessageRoute
+import Adhoc (adhocBotSession, commandList, queryCommandList)
+import StanzaRec
 
 instance Ord JID where
 	compare x y = compare (show x) (show y)
 
-data StanzaRec = StanzaRec (Maybe JID) (Maybe JID) (Maybe Text) (Maybe Text) [Element] Element deriving (Show)
-mkStanzaRec x = StanzaRec (stanzaTo x) (stanzaFrom x) (stanzaID x) (stanzaLang x) (stanzaPayloads x) (stanzaToElement x)
-instance Stanza StanzaRec where
-	stanzaTo (StanzaRec to _ _ _ _ _) = to
-	stanzaFrom (StanzaRec _ from _ _ _ _) = from
-	stanzaID (StanzaRec _ _ id _ _ _) = id
-	stanzaLang (StanzaRec _ _ _ lang _ _) = lang
-	stanzaPayloads (StanzaRec _ _ _ _ payloads _) = payloads
-	stanzaToElement (StanzaRec _ _ _ _ _ element) = element
-
-mkSMS from to txt = (emptyMessage MessageChat) {
-	messageTo = Just to,
-	messageFrom = Just from,
-	messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText txt]]
-}
-
 tcKey jid key = fmap (\node -> (T.unpack $ strNode node) <> "\0" <> key) (jidNode jid)
 tcGetJID db jid key = liftIO $ case tcKey jid key of
 	Just tck -> (parseJID . fromString =<<) <$> TC.runTCM (TC.get db tck)
@@ -81,8 +64,6 @@ tcPut db cheoJid key val = liftIO $ do
 	True <- TC.runTCM (TC.put db tck val)
 	return ()
 
-getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromString "body") (Just $ fromString ns) Nothing) <=< messagePayloads)
-
 queryDisco to from = queryDiscoWithNode Nothing to from
 
 queryDiscoWithNode node to from = do
@@ -94,19 +75,6 @@ queryDiscoWithNode node to from = do
 		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") (map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [ContentText node])) $ maybeToList node) []
 	}]
 
-queryCommandList' to from =
-	(emptyIQ IQGet) {
-		iqTo = Just to,
-		iqFrom = Just from,
-		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [
-			(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])
-		] []
-	}
-
-queryCommandList to from = do
-	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
-	return [mkStanzaRec $ (queryCommandList' to from) {iqID = uuid}]
-
 fillFormField var value form = form {
 		elementNodes = map (\node ->
 			case node of
@@ -250,41 +218,6 @@ telDiscoInfo q id from to disco =
 			) (sort $ nub $ telDiscoFeatures ++ disco)
 	}
 
-botHelp commandListIq@(IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payload }) =
-	mkSMS from to $ (s"Help:\n\t") ++ intercalate (s"\n\t") (map (\item ->
-		fromMaybe mempty (attributeText (s"node") item) ++ s": " ++
-		fromMaybe mempty (attributeText (s"name") item)
-	) items)
-	where
-	items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren payload
-
-commandList componentJid id from to extras =
-	(emptyIQ IQResult) {
-		iqTo = Just to,
-		iqFrom = Just from,
-		iqID = id,
-		iqPayload = Just $ Element (s"{http://jabber.org/protocol/disco#items}query")
-			[(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])]
-			([
-				NodeElement $ Element (s"{http://jabber.org/protocol/disco#items}item") [
-						(s"jid", [ContentText $ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName]),
-						(s"node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
-						(s"name", [ContentText $ s"Configure direct message route"])
-				] []
-			] ++ extraItems)
-	}
-	where
-	extraItems = map (\el ->
-			NodeElement $ el {
-				elementAttributes = map (\(aname, acontent) ->
-					if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
-						(aname, [ContentText $ formatJID componentJid])
-					else
-						(aname, acontent)
-				) (elementAttributes el)
-			}
-		) extras
-
 routeQueryOrReply db componentJid from smsJid resource query reply = do
 	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
 	case (fmap fromString maybeRoute, maybeRouteFrom) of
@@ -1838,61 +1771,28 @@ joinPartDebouncer db backendHost sendToComponent componentJid toRoomPresences to
 				| t == time -> sendPart cheoJid from time >> return state'
 			(_, state') -> return state'
 
-adhocBotRunCommand :: (UIO.Unexceptional m) => JID -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> JID -> Text -> [Element] -> m ()
-adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body cmdEls = do
-	let (nodes, cmds) = unzip $ mapMaybe (\el -> (,) <$> attributeText (s"node") el <*> pure el) cmdEls
-	case snd <$> (find (\(prefixes, _) -> Set.member body prefixes) $ zip (uniquePrefix nodes) cmds) of
-		Just cmd -> do
-			let cmdIQ = (emptyIQ IQSet) {
-				iqFrom = Just routeFrom,
-				iqTo = parseJID =<< (attributeText (s"jid") cmd),
-				iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText $ fromMaybe mempty $ attributeText (s"node") cmd])] []
-			}
-			mcmdResult <- atomicUIO =<< (UIO.lift $ sendIQ $ cmdIQ)
-			case mcmdResult of
-				Just resultIQ
-					| IQResult == iqType resultIQ,
-						Just payload <- iqPayload resultIQ,
-						[note] <- isNamed (s"{http://jabber.org/protocol/commands}note") =<< elementChildren payload ->
-						atomicUIO $ sendMessage $ mkSMS componentJid from $ mconcat $ elementText note
-					| otherwise -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command error")
-				Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command timed out")
-		Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs.  Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
-
-adhocBotSession :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> XMPP.Message -> m ()
-adhocBotSession db componentJid sendMessage sendIQ message@(XMPP.Message { XMPP.messageFrom = Just from })
-	| Just body <- getBody "jabber:component:accept" message,
-	  body == s"help" = do
-		maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
-		(atomicUIO . sendMessage) =<< case parseJID =<< fmap fromString maybeRoute of
-			Just route -> do
-				mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
-				return $ botHelp $ commandList componentJid Nothing componentJid from $
-					isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren =<< maybeToList (XMPP.iqPayload =<< mfilter ((== XMPP.IQResult) . XMPP.iqType) mreply)
-			Nothing ->
-				return $ botHelp $ commandList componentJid Nothing componentJid from []
-	| Just body <- getBody "jabber:component:accept" message = do
-		maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
-		case parseJID =<< fmap fromString maybeRoute of
-			Just route -> do
-				mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
-				case (iqPayload =<< mfilter ((==IQResult) . iqType) mreply) of
-					Just reply -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body (elementChildren reply)
-					Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body (elementChildren =<< (maybeToList $ iqPayload $ commandList componentJid Nothing componentJid from []))
-			Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body (elementChildren =<< (maybeToList $ iqPayload $ commandList componentJid Nothing componentJid from []))
-	| otherwise =
-		atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs.  Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
-	where
-	Just routeFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/adhocbot"
-adhocBotSession _ _ _ _ m = log "BAD ADHOC BOT MESSAGE" m
 
 adhocBotManager :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> (STM XMPP.Message) -> m ()
 adhocBotManager db componentJid sendMessage sendIQ messages = do
-	forever $ do
-		message <- atomicUIO messages
-		-- Lookup from map based on message from for a thread to send to
-		-- If no thread, make new one
-		UIO.fork $ adhocBotSession db componentJid sendMessage sendIQ message
+	cleanupChan <- atomicUIO newTChan
+	statefulManager cleanupChan Map.empty
+	where
+	statefulManager cleanupChan sessions = do
+		join $ atomicUIO $ (processMessage cleanupChan sessions <$> messages) <|> (cleanupSession cleanupChan sessions <$> readTChan cleanupChan)
+
+	cleanupSession cleanupChan sessions sessionToClean = statefulManager cleanupChan $! (Map.delete sessionToClean sessions)
+
+	processMessage cleanupChan sessions message = do
+		-- XXX: At some point this should not include resource, but it makes it easy to test for now
+		let key = bareTxt <$> (XMPP.stanzaFrom message)
+		sessions' <- case Map.lookup key sessions of
+			Just input -> input message >> return sessions
+			Nothing -> do
+				newChan <- atomicUIO newTChan
+				UIO.forkFinally (adhocBotSession db componentJid sendMessage sendIQ (readTChan newChan) message) (\_ -> atomicUIO $ writeTChan cleanupChan key)
+				let writer = (atomicUIO . writeTChan newChan)
+				return $ Map.insert key writer sessions
+		statefulManager cleanupChan sessions'
 
 openTokyoCabinet :: (TC.TCDB a) => String -> IO a
 openTokyoCabinet pth = TC.runTCM $ do
diff --git a/StanzaRec.hs b/StanzaRec.hs
new file mode 100644
index 0000000..f900af1
--- /dev/null
+++ b/StanzaRec.hs
@@ -0,0 +1,20 @@
+module StanzaRec (StanzaRec(..), mkStanzaRec) where
+
+import BasicPrelude
+import qualified Data.XML.Types as XML
+import qualified Network.Protocol.XMPP as XMPP
+import Network.Protocol.XMPP.Internal (Stanza(..))
+
+data StanzaRec = StanzaRec (Maybe XMPP.JID) (Maybe XMPP.JID) (Maybe Text) (Maybe Text) [XML.Element] XML.Element deriving (Show)
+
+instance Stanza StanzaRec where
+	stanzaTo (StanzaRec to _ _ _ _ _) = to
+	stanzaFrom (StanzaRec _ from _ _ _ _) = from
+	stanzaID (StanzaRec _ _ sid _ _ _) = sid
+	stanzaLang (StanzaRec _ _ _ lang _ _) = lang
+	stanzaPayloads (StanzaRec _ _ _ _ payloads _) = payloads
+	stanzaToElement (StanzaRec _ _ _ _ _ element) = element
+
+mkStanzaRec :: (Stanza s) => s -> StanzaRec
+mkStanzaRec x = StanzaRec (stanzaTo x) (stanzaFrom x) (stanzaID x) (stanzaLang x) (stanzaPayloads x) (stanzaToElement x)
+
diff --git a/Util.hs b/Util.hs
index 5f8e5a2..8d5003d 100644
--- a/Util.hs
+++ b/Util.hs
@@ -9,7 +9,7 @@ import Data.Char (isDigit)
 import Control.Applicative (many)
 import Control.Error (hush)
 import Data.Time (getCurrentTime)
-import Data.XML.Types as XML (Name, Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText)
+import Data.XML.Types as XML (Name(Name), Element(..), Node(NodeElement, NodeContent), Content(ContentText), isNamed, elementText, elementChildren, attributeText)
 import Crypto.Random (getSystemDRG, withRandomBytes)
 import Data.ByteString.Base58 (bitcoinAlphabet, encodeBase58)
 import Data.Digest.Pure.SHA (sha1, bytestringDigest)
@@ -124,9 +124,11 @@ parsePhoneContext txt = hush $ Atto.parseOnly (
 		<* Atto.endOfInput
 	) txt
 
+bareTxt :: XMPP.JID -> Text
 bareTxt (XMPP.JID (Just node) domain _) = mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
 bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain
 
+getFormField :: XML.Element -> Text -> Maybe Text
 getFormField form var =
 		listToMaybe $ mapMaybe (\node ->
 			case node of
@@ -206,3 +208,13 @@ discoToCaps query =
 discoToCapsHash :: XML.Element -> ByteString
 discoToCapsHash query =
 	LZ.toStrict $ bytestringDigest $ sha1 $ LZ.fromStrict $ T.encodeUtf8 $ discoToCaps query
+
+getBody :: String -> XMPP.Message -> Maybe Text
+getBody ns = listToMaybe . fmap (mconcat . XML.elementText) . (XML.isNamed (XML.Name (fromString "body") (Just $ fromString ns) Nothing) <=< XMPP.messagePayloads)
+
+mkSMS :: XMPP.JID -> XMPP.JID -> Text -> XMPP.Message
+mkSMS from to txt = (XMPP.emptyMessage XMPP.MessageChat) {
+	XMPP.messageTo = Just to,
+	XMPP.messageFrom = Just from,
+	XMPP.messagePayloads = [XML.Element (fromString "{jabber:component:accept}body") [] [XML.NodeContent $ XML.ContentText txt]]
+}
diff --git a/cheogram.cabal b/cheogram.cabal
index 4d66b13..a8a9af5 100644
--- a/cheogram.cabal
+++ b/cheogram.cabal
@@ -21,7 +21,7 @@ extra-source-files:
 
 executable cheogram
         main-is: Main.hs
-        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix
+        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc
         default-language: Haskell2010
         ghc-options:      -Wno-tabs -Wno-orphans
 
-- 
2.45.2