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