~singpolyma/cheogram

d2350b80153883b3caac74e7f35b40717c32163a — Stephen Paul Weber 5 years ago 16852f4
When submit no route, delete existing route

Closes #48
2 files changed, 44 insertions(+), 10 deletions(-)

M ConfigureDirectMessageRoute.hs
M Main.hs
M ConfigureDirectMessageRoute.hs => ConfigureDirectMessageRoute.hs +25 -6
@@ 21,7 21,7 @@ import Util

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

main :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> XMPP.JID -> IO ()) -> IO (XMPP.IQ -> IO XMPP.IQ)
main :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> IO (XMPP.IQ -> IO XMPP.IQ)
main getRouteJid setRouteJid = do
	stanzas <- newTQueueIO
	void $ forkIO $ iterateM_ (\sessions -> do


@@ 37,7 37,7 @@ main getRouteJid setRouteJid = do
			atomically $ readTMVar result
		)

processOneIQ :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, UTCTime), XMPP.IQ)
processOneIQ :: (XMPP.JID -> IO (Maybe XMPP.JID)) -> (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, UTCTime), XMPP.IQ)
processOneIQ getRouteJid setRouteJid 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 =


@@ 64,7 64,7 @@ processOneIQ _ _ sessions iq@(XMPP.IQ { XMPP.iqID = iqID, XMPP.iqFrom = from }) 
	log "ConfigureDirectMessageRoute.processOneIQ BAD INPUT" iq
	return (sessions, iqError iqID from "cancel" "feature-not-implemented" Nothing)

lookupAndStepSession :: (XMPP.JID -> XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> Session' (IO (Map SessionID (Session, UTCTime), XMPP.IQ))
lookupAndStepSession :: (XMPP.JID -> Maybe XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> Session' (IO (Map SessionID (Session, UTCTime), XMPP.IQ))
lookupAndStepSession setRouteJid sessions sid iqID from payload
	| Just (stepSession, _) <- Map.lookup sid sessions =
		if attributeText (s"{http://jabber.org/protocol/commands}action") payload == Just (s"cancel") then


@@ 87,7 87,7 @@ lookupAndStepSession setRouteJid sessions sid iqID from payload
				SessionCancel -> return $! Map.delete sid sessions
				SessionSaveAndNext userJid gatewayJid s -> do
					now <- getCurrentTime
					userJid `setRouteJid` gatewayJid
					userJid `setRouteJid` (Just gatewayJid)
					return $! Map.insert sid (s, now) sessions
				SessionComplete userJid gatewayJid -> do
					userJid `setRouteJid` gatewayJid


@@ 96,7 96,7 @@ lookupAndStepSession setRouteJid sessions 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 XMPP.JID
data SessionResult = SessionNext Session | SessionCancel | SessionSaveAndNext XMPP.JID XMPP.JID Session | SessionComplete XMPP.JID (Maybe XMPP.JID)
type Session' a = SessionID -> Text -> XMPP.JID -> Element -> a
type Session = Session' (SessionResult, XMPP.IQ)



@@ 111,7 111,7 @@ stage5 stage4iqID stage4from sid iqID from error
			XMPP.iqPayload = Just error
		})
	| otherwise =
		(SessionComplete stage4from from, (XMPP.emptyIQ XMPP.IQResult) {
		(SessionComplete stage4from (Just from), (XMPP.emptyIQ XMPP.IQResult) {
			XMPP.iqID = Just stage4iqID,
			XMPP.iqTo = Just stage4from,
			XMPP.iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command")


@@ 177,6 177,25 @@ stage2 sid iqID from command
			XMPP.iqFrom = Just sendFrom, -- domain gets rewritten by main cheogram program
			XMPP.iqPayload = Just $ Element (s"{jabber:iq:register}query") [] []
		})
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command,
	  getFormField form (s"gateway-jid") `elem` [Nothing, Just mempty] =
		(SessionComplete from Nothing, (XMPP.emptyIQ XMPP.IQResult) {
			XMPP.iqID = Just iqID,
			XMPP.iqTo = Just from,
			XMPP.iqPayload = Just $ 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 $ s"completed"])
				]
				[
					NodeElement $ Element (s"{http://jabber.org/protocol/commands}note") [
						(s"{http://jabber.org/protocol/commands}type", [ContentText $ s"info"])
					] [
						NodeContent $ ContentText $ s"Direct message route removed."
					]
				]
		})
	| otherwise = (SessionCancel, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-payload"))

stage1 :: Maybe XMPP.JID -> XMPP.JID -> Text -> SessionID -> XMPP.IQ

M Main.hs => Main.hs +19 -4
@@ 1485,10 1485,25 @@ main = do
				(\userJid ->
					(parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid) ++ "\0direct-message-route"))
				)
				(\userJid gatewayJid -> do
					log "SETTING DIRECT MESSAGE ROUTE" (userJid, gatewayJid)
					True <- TC.runTCM $ TC.put db (T.unpack (bareTxt userJid) ++ "\0direct-message-route") (T.unpack $ formatJID gatewayJid)
					return ()
				(\userJid mgatewayJid -> do
					log "SETTING DIRECT MESSAGE ROUTE" (userJid, mgatewayJid)
					case mgatewayJid of
						Just gatewayJid -> do
							True <- TC.runTCM $ TC.put db (T.unpack (bareTxt userJid) ++ "\0direct-message-route") (T.unpack $ formatJID gatewayJid)
							return ()
						Nothing -> do
							maybeExistingRoute <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid) ++ "\0direct-message-route"))
							True <- TC.runTCM $ TC.out db (T.unpack (bareTxt userJid) ++ "\0direct-message-route")
							forM_ maybeExistingRoute $ \existingRoute -> do
								uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
								atomically $ writeTChan sendToComponent $ mkStanzaRec $ (emptyIQ IQSet) {
										iqTo = Just existingRoute,
										iqFrom = parseJID $ escapeJid (bareTxt userJid) ++ s"@" ++ formatJID componentJid ++ s"/CHEOGRAM%removed",
										iqID = uuid,
										iqPayload = Just $ Element (s"{jabber:iq:register}query") [] [
											NodeElement $ Element (s"{jabber:iq:register}remove") [] []
										]
									}
				)

			forever $ do