~singpolyma/cheogram

56e23b4519d46be8adae6f7fa018fa35fb38140e — Christopher Vollick 4 months ago 3ad0a8d
Change JID Command

If the backend sends us a command we recognize as a JID change, we
intercept it and replace it with ours.

Ours asks which JID we want to move to and then asks that JID if it
wants to do this. When they register we ask them to confirm they want to
swap, and then send the backend the actual JID change operation.
8 files changed, 335 insertions(+), 58 deletions(-)

M Adhoc.hs
A CommandAction.hs
M ConfigureDirectMessageRoute.hs
A JidSwitch.hs
M Main.hs
M Makefile
M Util.hs
M cheogram.cabal
M Adhoc.hs => Adhoc.hs +18 -24
@@ 22,10 22,12 @@ import qualified Data.UUID.V1 as UUID ( nextUUID )
import qualified UnexceptionalIO.Trans ()
import qualified UnexceptionalIO as UIO

import CommandAction
import StanzaRec
import UniquePrefix
import Util
import qualified ConfigureDirectMessageRoute
import qualified JidSwitch
import qualified DB

sessionLifespan :: Int


@@ 48,6 50,19 @@ botHelp header (IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payloa
	items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren payload
botHelp _ _ = Nothing

-- This replaces certain commands that the SGX supports with our sugared versions
maskCommands :: XMPP.JID -> [Element] -> [Element]
maskCommands componentJid = map (\el ->
		if attributeText (s"node") el == Just JidSwitch.backendNodeName then
			Element (s"{http://jabber.org/protocol/disco#items}item") [
					(s"jid", [ContentText $ formatJID componentJid ++ s"/CHEOGRAM%" ++ JidSwitch.nodeName]),
					(s"node", [ContentText JidSwitch.nodeName]),
					(s"name", [ContentText $ s"Change your Jabber ID"])
			] []
		else
			el
	)

commandList :: JID -> Maybe Text -> JID -> JID -> [Element] -> IQ
commandList componentJid qid from to extras =
	(emptyIQ IQResult) {


@@ 65,8 80,8 @@ commandList componentJid qid from to extras =
			])
	}
	where
	extraItems = map (\el ->
			NodeElement $ el {
	extraItems = map NodeElement $ maskCommands componentJid $ map (\el ->
			el {
				elementAttributes = map (\(aname, acontent) ->
					if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
						(aname, [ContentText $ formatJID componentJid])


@@ 338,27 353,6 @@ renderResultForm form =
	where
	forAccumL z xs f = mapAccumL f z xs

data Action = ActionNext | ActionPrev | ActionCancel | ActionComplete

actionContent :: Action -> Content
actionContent ActionNext     = ContentText $ s"next"
actionContent ActionPrev     = ContentText $ s"prev"
actionContent ActionCancel   = ContentText $ s"cancel"
actionContent ActionComplete = ContentText $ s"complete"

actionCmd :: Action -> Text
actionCmd ActionNext     = s"next"
actionCmd ActionPrev     = s"back"
actionCmd ActionCancel   = s"cancel"
actionCmd ActionComplete = s"finish"

actionFromXMPP :: Text -> Maybe Action
actionFromXMPP xmpp
	| xmpp == s"next"     = Just ActionNext
	| xmpp == s"prev"     = Just ActionPrev
	| xmpp == s"complete" = Just ActionComplete
	| otherwise           = Nothing

waitForAction :: (UIO.Unexceptional m) => [Action] -> (Text -> m ()) -> m XMPP.Message -> m Action
waitForAction actions sendText getMessage = do
	m <- getMessage


@@ 585,7 579,7 @@ adhocBotSession db componentJid sendMessage sendIQ getMessage message@(XMPP.Mess
			Just route -> do
				mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
				case iqPayload =<< mfilter ((==IQResult) . iqType) mreply of
					Just reply -> adhocBotRunCommand db componentJid routeFrom sendMessage' sendIQ getMessage from body $ elementChildren reply ++ internalCommands
					Just reply -> adhocBotRunCommand db componentJid routeFrom sendMessage' sendIQ getMessage from body $ maskCommands componentJid $ elementChildren reply ++ internalCommands
					Nothing -> adhocBotRunCommand db componentJid routeFrom sendMessage' sendIQ getMessage from body internalCommands
			Nothing -> adhocBotRunCommand db componentJid routeFrom sendMessage' sendIQ getMessage from body internalCommands
	| otherwise = sendHelp db componentJid sendMessage' sendIQ from routeFrom

A CommandAction.hs => CommandAction.hs +35 -0
@@ 0,0 1,35 @@
module CommandAction where

import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Content(ContentText), isNamed, elementText, elementChildren, attributeText)

import qualified Data.Text as T
import qualified Data.XML.Types as XML

import Util

data Action = ActionNext | ActionPrev | ActionCancel | ActionComplete

actionContent :: Action -> Content
actionContent ActionNext     = ContentText $ s"next"
actionContent ActionPrev     = ContentText $ s"prev"
actionContent ActionCancel   = ContentText $ s"cancel"
actionContent ActionComplete = ContentText $ s"complete"

actionCmd :: Action -> T.Text
actionCmd ActionNext     = s"next"
actionCmd ActionPrev     = s"back"
actionCmd ActionCancel   = s"cancel"
actionCmd ActionComplete = s"finish"

actionFromXMPP :: T.Text -> Maybe Action
actionFromXMPP xmpp
	| xmpp == s"next"     = Just ActionNext
	| xmpp == s"prev"     = Just ActionPrev
	| xmpp == s"complete" = Just ActionComplete
	| otherwise           = Nothing

actionToEl :: Action -> [Element]
actionToEl ActionNext = [Element (s"{http://jabber.org/protocol/commands}next") [] []]
actionToEl ActionPrev = [Element (s"{http://jabber.org/protocol/commands}prev") [] []]
actionToEl ActionComplete = [Element (s"{http://jabber.org/protocol/commands}complete") [] []]
actionToEl ActionCancel = []

M ConfigureDirectMessageRoute.hs => ConfigureDirectMessageRoute.hs +135 -16
@@ 20,15 20,22 @@ import qualified Data.Bool.HT as HT
import qualified Data.XML.Types as XML

import Util
import qualified JidSwitch

newtype SessionID = SessionID UUID deriving (Ord, Eq, Show)

main :: XMPP.Domain -> (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> IO (XMPP.IQ -> IO (Maybe XMPP.IQ))
main componentDomain getPossibleRoute getRouteJid setRouteJid = do
type GetPossibleRoute = XMPP.JID -> IO (Maybe XMPP.JID)
type GetPossibleSwitch = XMPP.JID -> IO (Maybe (XMPP.JID, XMPP.JID, XMPP.JID))
type GetRouteJid = XMPP.JID -> IO (Maybe XMPP.JID)
type SetRouteJid = XMPP.JID -> Maybe XMPP.JID -> IO ()
type ClearSwitch = XMPP.JID -> IO ()

main :: XMPP.Domain -> GetPossibleRoute -> GetPossibleSwitch -> GetRouteJid -> SetRouteJid -> ClearSwitch -> IO (XMPP.IQ -> IO (Maybe XMPP.IQ))
main componentDomain getPossibleRoute getPossibleSwitch getRouteJid setRouteJid clearSwitch = do
	stanzas <- newTQueueIO
	void $ forkIO $ iterateM_ (\sessions -> do
			(iq, reply) <- atomically (readTQueue stanzas)
			(sessions', response) <- processOneIQ componentDomain getPossibleRoute getRouteJid setRouteJid sessions iq
			(sessions', response) <- processOneIQ componentDomain getPossibleRoute getPossibleSwitch getRouteJid setRouteJid clearSwitch sessions iq
			atomically $ reply response
			now <- getCurrentTime
			return $! Map.filter (\(_, time) -> now `diffUTCTime` time < 600) sessions'


@@ 39,11 46,11 @@ main componentDomain getPossibleRoute getRouteJid setRouteJid = do
			atomically $ readTMVar result
		)

processOneIQ :: XMPP.Domain -> (XMPP.JID -> IO (Maybe XMPP.JID)) -> (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 componentDomain getPossibleRoute getRouteJid setRouteJid sessions iq@(XMPP.IQ { XMPP.iqID = Just iqID, XMPP.iqFrom = Just from, XMPP.iqPayload = realPayload })
processOneIQ :: XMPP.Domain -> GetPossibleRoute -> GetPossibleSwitch -> GetRouteJid -> SetRouteJid -> ClearSwitch -> Map SessionID (Session, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, UTCTime), Maybe XMPP.IQ)
processOneIQ componentDomain getPossibleRoute getPossibleSwitch getRouteJid setRouteJid clearSwitch 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 =
		(fmap Just) <$> lookupAndStepSession setRouteJid sessions componentDomain sid iqID from payload
		(fmap Just) <$> lookupAndStepSession setRouteJid clearSwitch sessions componentDomain 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)


@@ 52,13 59,19 @@ processOneIQ componentDomain getPossibleRoute getRouteJid setRouteJid sessions i
		else
			return (sessions, Just $ iqError (Just iqID) (Just from) "cancel" "feature-not-implemented" Nothing)
	| Just sid <- sessionIDFromText =<< attributeText (s"sessionid") payload =
		(fmap Just) <$> lookupAndStepSession setRouteJid sessions componentDomain sid iqID from payload
		(fmap Just) <$> lookupAndStepSession setRouteJid clearSwitch sessions componentDomain sid iqID from payload
	| otherwise = do
		(sid, session) <- newSession
		now <- getCurrentTime
		existingRoute <- getRouteJid from
		possibleRoute <- getPossibleRoute from
		return (Map.insert sid (session, now) sessions, Just $ stage1 possibleRoute existingRoute from iqID sid)
		possibleSwitch <- getPossibleSwitch from
		case possibleSwitch of
			Just (newJid, switchJid, switchRoute) -> do
				(sid, session) <- newSession $ switchStage2 switchJid switchRoute possibleRoute existingRoute
				return (Map.insert sid (session, now) sessions, Just $ switchStage1 newJid switchJid switchRoute possibleRoute existingRoute from iqID sid)
			_ -> do
				(sid, session) <- newSession stage2
				return (Map.insert sid (session, now) sessions, Just $ stage1 possibleRoute existingRoute from iqID sid)
	where
	payload
		| Just p <- realPayload,


@@ 66,12 79,12 @@ processOneIQ componentDomain getPossibleRoute getRouteJid setRouteJid sessions i
		| XMPP.iqType iq == XMPP.IQError =
			let Just p = XMPP.iqPayload $ iqError Nothing Nothing "cancel" "internal-server-error" Nothing in p
		| otherwise = fromMaybe (Element (s"no-payload") [] []) realPayload
processOneIQ _ _ _ _ sessions iq@(XMPP.IQ { XMPP.iqID = iqID, XMPP.iqFrom = from }) = do
processOneIQ _ _ _ _ _ _ sessions iq@(XMPP.IQ { XMPP.iqID = iqID, XMPP.iqFrom = from }) = do
	log "ConfigureDirectMessageRoute.processOneIQ BAD INPUT" iq
	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 componentDomain sid iqID from payload
lookupAndStepSession :: SetRouteJid -> ClearSwitch -> Map SessionID (Session, UTCTime) -> Session' (IO (Map SessionID (Session, UTCTime), XMPP.IQ))
lookupAndStepSession setRouteJid clearSwitch sessions componentDomain sid iqID from payload
	| Just (stepSession, _) <- Map.lookup sid sessions =
		case attributeText (s"action") payload of
			Just action | action == s"cancel" ->


@@ 119,6 132,15 @@ lookupAndStepSession setRouteJid sessions componentDomain sid iqID from payload
						now <- getCurrentTime
						userJid `setRouteJid` (Just gatewayJid)
						return $! Map.insert sid (s, now) sessions
					SessionClearSwitchAndNext userJid s -> do
						now <- getCurrentTime
						clearSwitch userJid
						return $! Map.insert sid (s, now) sessions
					SessionCompleteSwitch userJid oldJid gatewayJid -> do
						userJid `setRouteJid` Just gatewayJid
						oldJid `setRouteJid` Nothing
						clearSwitch userJid
						return $! Map.delete sid sessions
					SessionComplete userJid gatewayJid -> do
						userJid `setRouteJid` gatewayJid
						return $! Map.delete sid sessions


@@ 126,7 148,7 @@ lookupAndStepSession setRouteJid sessions componentDomain sid iqID from payload
		log "ConfigureDirectMessageRoute.processOneIQ NO SESSION FOUND" (sid, iqID, from, payload)
		return (sessions, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-sessionid"))

data SessionResult = SessionNext Session | SessionCancel | SessionSaveAndNext XMPP.JID XMPP.JID Session | SessionComplete XMPP.JID (Maybe XMPP.JID)
data SessionResult = SessionNext Session | SessionCancel | SessionSaveAndNext XMPP.JID XMPP.JID Session | SessionClearSwitchAndNext XMPP.JID Session | SessionCompleteSwitch XMPP.JID XMPP.JID XMPP.JID | SessionComplete XMPP.JID (Maybe XMPP.JID)
type Session' a = XMPP.Domain -> SessionID -> Text -> XMPP.JID -> Element -> a
type Session = Session' (SessionResult, XMPP.IQ)



@@ 305,6 327,103 @@ proxyAdHocFromUser prevIqID otherSID gatewayJid componentDomain _ iqID from comm
	where
	sendFrom = sendFromForBackend componentDomain from

switchStage1 :: XMPP.JID -> XMPP.JID -> XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID -> XMPP.JID -> Text -> SessionID -> XMPP.IQ
switchStage1 newJid switchJid switchRoute possibleRoute existingRoute iqTo iqID sid = (XMPP.emptyIQ XMPP.IQResult) {
	XMPP.iqTo = Just iqTo,
	XMPP.iqID = Just iqID,
	XMPP.iqPayload = Just $ commandStage sid False $
		Element (fromString "{jabber:x:data}x") [
			(fromString "{jabber:x:data}type", [ContentText $ s"form"])
		] [
			NodeElement $ Element (fromString "{jabber:x:data}title") [] [NodeContent $ ContentText $ s"Accept Jabber ID Change"],
			NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [
				NodeContent $ ContentText $ concat [
					s"It appears that the Jabber ID \"",
					bareTxt switchJid,
					s"\" has requested a migration to this Jabber ID (",
					bareTxt newJid,
					s"). If this isn't expected, respond no to the following to register normally"
				]
			],
			NodeElement $ Element (fromString "{jabber:x:data}field") [
				(fromString "{jabber:x:data}type", [ContentText $ s"boolean"]),
				(fromString "{jabber:x:data}var", [ContentText $ s"confirm"]),
				(fromString "{jabber:x:data}label", [ContentText $ s"Do you accept the migration?"])
			] []
		]
}

switchStage2 :: XMPP.JID -> XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID -> Session
switchStage2 switchJid switchRoute possibleRoute existingRoute componentDomain sid iqID from command
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command,
	  Just True <- parseBool =<< getFormField form (s"confirm") =
		(
			SessionNext $ switchStage3 switchJid switchRoute iqID from,
			(XMPP.emptyIQ XMPP.IQSet) {
				XMPP.iqID = Just (s"ConfigureDirectMessageRoute2" ++ sessionIDToText sid),
				XMPP.iqTo = Just switchRoute,
				XMPP.iqFrom = Just $ sendFromForBackend componentDomain switchJid,
				XMPP.iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText JidSwitch.backendNodeName])] []
			}
		)
	| otherwise =
		(
			SessionClearSwitchAndNext from stage2,
			stage1 possibleRoute existingRoute from iqID sid
		)

switchStage3 :: XMPP.JID -> XMPP.JID -> Text -> XMPP.JID -> Session
switchStage3 switchJid switchRoute stage2ID stage2From componentDomain sid iqID from command
	| Just backendSid <- attributeText (s"sessionid") command,
	  [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command,
	  isJust $ getFormField form $ s"jid" =
		(
			SessionNext $ switchStage4 switchJid switchRoute stage2ID stage2From,
			(XMPP.emptyIQ XMPP.IQSet) {
				XMPP.iqTo = Just from,
				XMPP.iqFrom = Just $ sendFromForBackend componentDomain switchJid,
				XMPP.iqID = Just (s"ConfigureDirectMessageRoute3" ++ sessionIDToText sid),
				XMPP.iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [
						(s"node", [ContentText JidSwitch.backendNodeName]),
						(s"sessionid", [ContentText $ backendSid])
					] [
						NodeElement $ Element (fromString "{jabber:x:data}x") [
							(fromString "{jabber:x:data}type", [ContentText $ s"submit"])
						] [
							NodeElement $ Element (fromString "{jabber:x:data}field") [
								(fromString "{jabber:x:data}var", [ContentText $ s"jid"])
							] [
								NodeElement $ Element (fromString "{jabber:x:data}value") [] [NodeContent $ ContentText $ bareTxt stage2From]
							]
						]
					]
			}
			)
	| otherwise = (SessionCancel, iqError (Just stage2ID) (Just stage2From) "cancel" "internal-server-error" Nothing)

switchStage4 :: XMPP.JID -> XMPP.JID -> Text -> XMPP.JID -> Session
switchStage4 switchJid switchRoute stage2ID stage2From componentDomain sid iqID from command
	| attributeText (s"status") command == Just (s"canceled") = (SessionCancel, proxied)
	| attributeText (s"status") command == Just (s"completed") =
		if (s"error") `elem` mapMaybe (attributeText (s"type")) (XML.isNamed (s"{http://jabber.org/protocol/commands}note") =<< XML.elementChildren command) then
			(SessionCancel, proxied)
		else
			(SessionCompleteSwitch stage2From switchJid switchRoute, proxied)
	where
	proxied =
		(XMPP.emptyIQ XMPP.IQResult) {
			XMPP.iqID = Just stage2ID,
			XMPP.iqTo = Just stage2From,
			XMPP.iqPayload = Just $ command {
				XML.elementAttributes = map (\attr@(name, _) ->
					HT.select attr [
						(name == s"node", (name, [ContentText nodeName])),
						(name == s"sessionid", (name, [ContentText $ sessionIDToText sid]))
					]
				) (XML.elementAttributes command)
			}
		}

stage1 :: Maybe XMPP.JID -> Maybe XMPP.JID -> XMPP.JID -> Text -> SessionID -> XMPP.IQ
stage1 possibleRoute existingRoute iqTo iqID sid = (XMPP.emptyIQ XMPP.IQResult) {
	XMPP.iqTo = Just iqTo,


@@ 364,10 483,10 @@ commandStage sid allowComplete el = Element (s"{http://jabber.org/protocol/comma
				NodeElement $ Element (s"{http://jabber.org/protocol/commands}next") [] []
			]

newSession :: IO (SessionID, Session)
newSession = UUID.nextUUID >>= go
newSession :: Session -> IO (SessionID, Session)
newSession nextStage = UUID.nextUUID >>= go
	where
	go (Just uuid) = return (SessionID uuid, stage2)
	go (Just uuid) = return (SessionID uuid, nextStage)
	go Nothing = do
		log "ConfigureDirectMessageRoute.newSession" "UUID generation failed"
		UUID.nextUUID >>= go

A JidSwitch.hs => JidSwitch.hs +102 -0
@@ 0,0 1,102 @@
module JidSwitch where

import Prelude ()
import BasicPrelude hiding (log)
import Data.UUID (UUID)
import qualified Data.UUID as UUID (toString, fromString)
import qualified Data.UUID.V1 as UUID (nextUUID)
import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(..), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText)
import qualified Network.Protocol.XMPP as XMPP

import Util
import CommandAction
import StanzaRec

import qualified DB

backendNodeName :: Text
backendNodeName = s"https://ns.cheogram.com/sgx/jid-switch"

nodeName :: Text
nodeName = s"change jabber id"

newtype SessionID = SessionID UUID deriving (Ord, Eq, Show)

sessionIDFromText :: Text -> Maybe SessionID
sessionIDFromText txt = SessionID <$> UUID.fromString (textToString txt)

sessionIDToText :: SessionID -> Text
sessionIDToText (SessionID uuid) = fromString $ UUID.toString uuid

type FromJID = XMPP.JID
type Route = XMPP.JID

fromAssoc :: [(Text, Maybe Text)] -> Maybe (FromJID, Route)
fromAssoc assoc = (,) <$> (XMPP.parseJID =<< join (lookup (s"from") assoc)) <*> (XMPP.parseJID =<< join (lookup (s"route") assoc))

toAssoc :: FromJID -> Route -> [(Text, Maybe Text)]
toAssoc from route = [(s"from", Just $ bareTxt from), (s"route", Just $ bareTxt route)]

newSession :: IO SessionID
newSession = UUID.nextUUID >>= go
	where
	go (Just uuid) = return $ SessionID uuid
	go Nothing = do
		log "JidSwitch.newSession" "UUID generation failed"
		UUID.nextUUID >>= go

receiveIq componentJid setJidSwitch iq@(XMPP.IQ { XMPP.iqFrom = Just from, XMPP.iqPayload = Just realPayload })
	| [command] <- isNamed (fromString "{http://jabber.org/protocol/commands}command") =<< [realPayload],
	  Just sid <- sessionIDFromText =<< attributeText (s"sessionid") command,
	  [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command,
	  Just newJid <- XMPP.parseJID =<< getFormField form (s"new-jid") = do
		(from', newJid', _) <- setJidSwitch newJid
		return [
			mkStanzaRec $ mkSMS componentJid newJid $ concat [
				bareTxt from',
				s" has requested a Jabber ID change to ",
				bareTxt newJid',
				s". To complete this request send \"register\""
			],
			mkStanzaRec $ flip iqReply iq $ Just $ commandStage sid [] (s"completed") $
				Element (s"{http://jabber.org/protocol/commands}note") [
					(s"{http://jabber.org/protocol/commands}type", [ContentText $ s"info"])
				] [
					NodeContent $ ContentText $ s"Please check for a message on " ++ bareTxt newJid'
				]
			]
	| otherwise = do
		sid <- newSession
		return [mkStanzaRec $ stage1 sid iq]

stage1 sid iq = flip iqReply iq $ Just $ commandStage sid [ActionComplete] (s"executing") $
	Element (fromString "{jabber:x:data}x") [
		(fromString "{jabber:x:data}type", [ContentText $ s"form"])
	] [
		NodeElement $ Element (fromString "{jabber:x:data}title") [] [NodeContent $ ContentText $ s"Change Jabber ID"],
		NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [
			NodeContent $ ContentText $ s"Enter the Jabber ID you'd like to move your account to"
		],
		NodeElement $ Element (fromString "{jabber:x:data}field") [
			(fromString "{jabber:x:data}type", [ContentText $ s"jid-single"]),
			(fromString "{jabber:x:data}var", [ContentText $ s"new-jid"]),
			(fromString "{jabber:x:data}label", [ContentText $ s"New Jabber ID"])
		] []
	]

commandStage :: SessionID -> [Action] -> Text -> Element -> Element
commandStage sid acceptedActions status el = Element (s"{http://jabber.org/protocol/commands}command")
	[
		(s"{http://jabber.org/protocol/commands}node", [ContentText nodeName]),
		(s"{http://jabber.org/protocol/commands}sessionid", [ContentText $ sessionIDToText sid]),
		(s"{http://jabber.org/protocol/commands}status", [ContentText status])
	]
	(actions ++ [NodeElement el])
	where
	actions
		| null acceptedActions = []
		| otherwise = [
				NodeElement $ Element (s"{http://jabber.org/protocol/commands}actions") [
					(s"{http://jabber.org/protocol/commands}execute", [actionContent $ head acceptedActions])
				] (map NodeElement $ concatMap actionToEl acceptedActions)
			]

M Main.hs => Main.hs +34 -15
@@ 48,6 48,7 @@ import Network.Protocol.XMPP as XMPP -- should import qualified
import Util
import IQManager
import qualified ConfigureDirectMessageRoute
import qualified JidSwitch
import qualified Config
import qualified DB
import Adhoc (adhocBotSession, commandList, queryCommandList)


@@ 138,6 139,18 @@ code str status =
	<>
	hasAttributeText (fromString "code") (== fromString str) status

-- When we're talking to the adhoc bot we'll get a command from stuff\40example.com@cheogram.com
-- When they're talking to us directly, we'll get the command from stuff@example.com
-- In either case, we want to use the same key and understand it as coming from the same user
maybeUnescape componentJid userJid
	| jidDomain userJid == jidDomain componentJid,
	  Just node <- jidNode userJid =
		let resource = maybe mempty strResource $ jidResource userJid
		in
		-- If we can't parse the thing we unescaped, just return the original
		fromMaybe userJid $ parseJID (unescapeJid (strNode node) ++ if T.null resource then mempty else s"/" ++ resource)
	| otherwise = userJid

cheogramDiscoInfo db componentJid sendIQ from q = do
	canVoice <- isJust <$> getSipProxy db componentJid sendIQ from
	return $ Element (s"{http://jabber.org/protocol/disco#info}query")


@@ 905,6 918,15 @@ componentStanza (ComponentContext { processDirectMessageRouteConfig, componentJi
			return $ subscribe ++ [mkStanzaRec $ replyIQ {
				iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
			}]
componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ iq@(IQ { iqTo = Just (JID { jidNode = Nothing }), iqPayload = payload, iqFrom = Just from }))
	| fmap elementName payload == Just (s"{http://jabber.org/protocol/commands}command") && (attributeText (s"node") =<< payload) == Just JidSwitch.nodeName =
		let setJidSwitch newJid = do
			let from' = maybeUnescape componentJid from
			Just route <- (XMPP.parseJID <=< id) <$> DB.get db (DB.byJid from' ["direct-message-route"])
			DB.hset db (DB.byJid newJid ["jidSwitch"]) $ JidSwitch.toAssoc from' route
			return (from', newJid, route)
		in
		map mkStanzaRec <$> JidSwitch.receiveIq componentJid setJidSwitch iq
componentStanza (ComponentContext { db, 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",


@@ 2068,29 2090,22 @@ main = do
			void $ forkIO $ forever $ atomically (writeTChan toRejoinManager CheckPings) >> threadDelay 120000000
			void $ forkIO $ rejoinManager db (atomically . writeTChan sendToComponent) (textToString $ formatJID componentJid) toRoomPresences toRejoinManager

			-- When we're talking to the adhoc bot we'll get a command from stuff\40example.com@cheogram.com
			-- When they're talking to us directly, we'll get the command from stuff@example.com
			-- In either case, we want to use the same key and understand it as coming from the same user
			let maybeUnescape userJid
				| jidDomain userJid == jidDomain componentJid,
				  Just node <- jidNode userJid =
					let resource = maybe mempty strResource $ jidResource userJid
					in
					-- If we can't parse the thing we unescaped, just return the original
					fromMaybe userJid $ parseJID (unescapeJid (strNode node) ++ if T.null resource then mempty else s"/" ++ resource)
				| otherwise = userJid

			processDirectMessageRouteConfig <- ConfigureDirectMessageRoute.main (XMPP.jidDomain componentJid)
				(\userJid ->
					let userJid' = maybeUnescape userJid in
					let userJid' = maybeUnescape componentJid userJid in
					(parseJID =<<) <$> DB.get db (DB.byJid userJid' ["possible-route"])
				)
				(\userJid -> do
					let userJid' = maybeUnescape componentJid userJid
					res <- (JidSwitch.fromAssoc) <$> DB.hgetall db (DB.byJid userJid' ["jidSwitch"])
					return $ fmap (\(x,y) -> (userJid', x, y)) res
				)
				(\userJid ->
					let userJid' = maybeUnescape userJid in
					let userJid' = maybeUnescape componentJid userJid in
					(parseJID =<<) <$> DB.get db (DB.byJid userJid' ["direct-message-route"])
				)
				(\userJid mgatewayJid -> do
					let userJid' = maybeUnescape userJid
					let userJid' = maybeUnescape componentJid userJid
					DB.del db (DB.byJid userJid' ["possible-route"])
					case mgatewayJid of
						Just gatewayJid -> do


@@ 2117,6 2132,10 @@ main = do
							forM_ maybeExistingRoute $ \existingRoute ->
								atomically . writeTChan sendToComponent . mkStanzaRec =<< unregisterDirectMessageRoute db componentJid userJid' existingRoute
				)
				(\userJid ->
					let userJid' = maybeUnescape componentJid userJid in
					DB.del db (DB.byJid userJid' ["jidSwitch"])
				)

			jingleHandler <- UIO.runEitherIO $ Jingle.setupJingleHandlers jingleStore s5bListenOn (fromString s5bhost, s5bport)
				(log "JINGLE")

M Makefile => Makefile +2 -2
@@ 5,10 5,10 @@ HLINTFLAGS=-XHaskell2010 -XCPP -i 'Use camelCase' -i 'Use String' -i 'Use head' 

all: report.html cheogram

cheogram: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs
cheogram: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs JidSwitch.hs
	ghc -dynamic -package monads-tf -o cheogram $(GHCFLAGS) Main.hs

report.html: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs
report.html: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs JidSwitch.hs
	-hlint $(HLINTFLAGS) --report $^

shell:

M Util.hs => Util.hs +8 -0
@@ 291,3 291,11 @@ queryDiscoWithNode' node to from =
			(map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [XML.ContentText node])) $ maybeToList node)
			[]
	}

parseBool :: Text -> Maybe Bool
parseBool input
	| s"true" == input = Just True
	| s"1" == input = Just True
	| s"false" == input = Just False
	| s"0" == input = Just False
	| otherwise = Nothing

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, UniquePrefix, StanzaRec, Adhoc, Config, DB
        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc, Config, DB, JidSwitch
        default-language: Haskell2010
        ghc-options:      -Wall -Wno-tabs -Wno-orphans -Wno-name-shadowing -O -threaded