~singpolyma/cheogram

e3dd039a7130972de67da630f300c71cc3e4f596 — Stephen Paul Weber 11 months ago 59b3ea7
Send support contact addresses as part of help text, if available
3 files changed, 32 insertions(+), 13 deletions(-)

M Adhoc.hs
M Main.hs
M Util.hs
M Adhoc.hs => Adhoc.hs +19 -8
@@ 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" ()


M Main.hs => Main.hs +2 -5
@@ 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 {

M Util.hs => Util.hs +11 -0
@@ 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)
			[]
	}