3 files changed, 32 insertions(+), 13 deletions(-)

M Adhoc.hs
M Main.hs
M Util.hs

@@ 38,15 38,15 @@ addOriginUUID msg = maybe msg (addTag msg) <$> fromIO_ UUID.nextUUID
 	where
 	addTag msg uuid = msg { messagePayloads = Element (s"{urn:xmpp:sid:0}origin-id") [(s"id", [ContentText $ UUID.toText uuid])] [] : messagePayloads msg }
 
-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 ->
+botHelp :: Maybe Text -> IQ -> Maybe Message
+botHelp header (IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payload }) =
+	Just $ mkSMS from to $ maybe mempty (++ s"\n") header ++ (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
+botHelp _ _ = Nothing
 
 commandList :: JID -> Maybe Text -> JID -> JID -> [Element] -> IQ
 commandList componentJid qid from to extras =


@@ 378,6 378,12 @@ registerShorthand body = do
 	gatewayJID <- hush $ Atto.parseOnly (Atto.asciiCI (s"register") *> Atto.many1 Atto.space *> Atto.takeText) body
 	parseJID gatewayJID
 
+getServerInfoForm :: [XML.Element] -> Maybe XML.Element
+getServerInfoForm = find (\el ->
+		attributeText (s"type") el == Just (s"result") &&
+		getFormField el (s"FORM_TYPE") == Just (s"http://jabber.org/network/serverinfo")
+	) . (isNamed (s"{jabber:x:data}x") =<<)
+
 sendHelp :: (UIO.Unexceptional m, TC.TCDB db) =>
 	   db
 	-> JID


@@ 390,14 396,19 @@ sendHelp db componentJid sendMessage sendIQ from routeFrom = 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)
+			replySTM <- UIO.lift $ sendIQ $ queryCommandList' route routeFrom
+			discoInfoSTM <- UIO.lift $ sendIQ $ queryDiscoWithNode' Nothing route routeFrom
+			(mreply, mDiscoInfo) <- atomicUIO $ (,) <$> replySTM <*> discoInfoSTM
+
+			let helpMessage = botHelp
+				(renderResultForm <$> (getServerInfoForm . elementChildren =<< iqPayload =<< mDiscoInfo)) $
+				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 -> sendMessage msg
 				Nothing -> log "INVALID HELP MESSAGE" mreply
 		Nothing ->
-			case botHelp $ commandList componentJid Nothing componentJid from [] of
+			case botHelp Nothing $ commandList componentJid Nothing componentJid from [] of
 				Just msg -> sendMessage msg
 				Nothing -> log "INVALID HELP MESSAGE" ()
 

@@ 67,11 67,8 @@ queryDisco to from = (:[]) . mkStanzaRec <$> queryDiscoWithNode Nothing to from
 
 queryDiscoWithNode node to from = do
 	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
-	return $ (emptyIQ IQGet) {
-		iqTo = Just to,
-		iqFrom = Just from,
-		iqID = uuid,
-		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) []
+	return $ (queryDiscoWithNode' node to from) {
+		iqID = uuid
 	}
 
 fillFormField var value form = form {

@@ 270,3 270,14 @@ queryCommandList' to from = (XMPP.emptyIQ XMPP.IQGet) {
 		(s"{http://jabber.org/protocol/disco#items}node", [XML.ContentText $ s"http://jabber.org/protocol/commands"])
 	] []
 }
+
+queryDiscoWithNode' :: Maybe Text -> XMPP.JID -> XMPP.JID -> XMPP.IQ
+queryDiscoWithNode' node to from =
+	(XMPP.emptyIQ XMPP.IQGet) {
+		XMPP.iqTo = Just to,
+		XMPP.iqFrom = Just from,
+		XMPP.iqPayload = Just $ XML.Element
+			(s"{http://jabber.org/protocol/disco#info}query")
+			(map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [XML.ContentText node])) $ maybeToList node)
+			[]
+	}