~singpolyma/cheogram

8f9ebf57a324a7ae79bd7a65627968139368e910 — Stephen Paul Weber 2 years ago 6d26466
Command-only commands work

That is, if the command returns completed immediately with a note, the
note is returned to the user.  Anything else is treated as an error.
2 files changed, 35 insertions(+), 2 deletions(-)

M Main.hs
M cheogram.cabal
M Main.hs => Main.hs +34 -1
@@ 25,6 25,7 @@ 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 (Type)
import qualified Jingle


@@ 45,6 46,7 @@ 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


@@ 1811,10 1813,30 @@ 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) $ traceShowId $ 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,
	  Just routeFrom <- parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/adhocbot",
	  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


@@ 1824,8 1846,19 @@ adhocBotSession db componentJid sendMessage sendIQ message@(XMPP.Message { XMPP.
					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 ()

M cheogram.cabal => cheogram.cabal +1 -1
@@ 21,7 21,7 @@ extra-source-files:

executable cheogram
        main-is: Main.hs
        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager
        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix
        default-language: Haskell2010
        ghc-options:      -Wno-tabs -Wno-orphans