From 56e23b4519d46be8adae6f7fa018fa35fb38140e Mon Sep 17 00:00:00 2001 From: Christopher Vollick <0@psycoti.ca> Date: Tue, 26 Apr 2022 16:03:43 -0400 Subject: [PATCH] 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. --- Adhoc.hs | 42 ++++----- CommandAction.hs | 35 ++++++++ ConfigureDirectMessageRoute.hs | 151 +++++++++++++++++++++++++++++---- JidSwitch.hs | 102 ++++++++++++++++++++++ Main.hs | 49 +++++++---- Makefile | 4 +- Util.hs | 8 ++ cheogram.cabal | 2 +- 8 files changed, 335 insertions(+), 58 deletions(-) create mode 100644 CommandAction.hs create mode 100644 JidSwitch.hs diff --git a/Adhoc.hs b/Adhoc.hs index 53c20b9..657bc16 100644 --- a/Adhoc.hs +++ b/Adhoc.hs @@ -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 diff --git a/CommandAction.hs b/CommandAction.hs new file mode 100644 index 0000000..1f68e88 --- /dev/null +++ b/CommandAction.hs @@ -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 = [] diff --git a/ConfigureDirectMessageRoute.hs b/ConfigureDirectMessageRoute.hs index 269facb..137b4b5 100644 --- a/ConfigureDirectMessageRoute.hs +++ b/ConfigureDirectMessageRoute.hs @@ -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 diff --git a/JidSwitch.hs b/JidSwitch.hs new file mode 100644 index 0000000..fd22f51 --- /dev/null +++ b/JidSwitch.hs @@ -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) + ] diff --git a/Main.hs b/Main.hs index b250ab4..3bfa3d6 100644 --- a/Main.hs +++ b/Main.hs @@ -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") diff --git a/Makefile b/Makefile index 4a7373e..2d0ee5b 100644 --- a/Makefile +++ b/Makefile @@ -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: diff --git a/Util.hs b/Util.hs index d354d8f..33fc4c4 100644 --- a/Util.hs +++ b/Util.hs @@ -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 diff --git a/cheogram.cabal b/cheogram.cabal index e4693c4..fbdebd1 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, 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 -- 2.34.2