~singpolyma/cheogram

85dddc641a4bd444823c238380bc38c4b277817a — Stephen Paul Weber 20 days ago 248f580 master
Allow users to opt-in to JID discoverability

So that we can actually build out this feature and turn it on in a way that
respects users right to not want this.
2 files changed, 101 insertions(+), 52 deletions(-)

M ConfigureDirectMessageRoute.hs
M Main.hs
M ConfigureDirectMessageRoute.hs => ConfigureDirectMessageRoute.hs +93 -52
@@ 31,16 31,18 @@ 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 ()
type GetAllowJidDiscovery = XMPP.JID -> IO (Maybe Bool)
type SetAllowJidDiscovery = XMPP.JID -> Bool -> IO ()

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


@@ 48,11 50,11 @@ main componentDomain getPossibleRoute getPossibleSwitch getRouteJid setRouteJid 
			atomically $ readTMVar result
		)

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 })
processOneIQ :: XMPP.Domain -> GetPossibleRoute -> GetPossibleSwitch -> GetRouteJid -> SetRouteJid -> ClearSwitch -> GetAllowJidDiscovery -> SetAllowJidDiscovery -> Map SessionID (Session, Maybe Bool, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, Maybe Bool, UTCTime), Maybe XMPP.IQ)
processOneIQ componentDomain getPossibleRoute getPossibleSwitch getRouteJid setRouteJid clearSwitch getAllowJidDiscovery setAllowJidDiscovery 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 clearSwitch sessions componentDomain sid iqID from payload
		(fmap Just) <$> lookupAndStepSession setRouteJid clearSwitch setAllowJidDiscovery 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)


@@ 61,19 63,20 @@ processOneIQ componentDomain getPossibleRoute getPossibleSwitch getRouteJid setR
		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 clearSwitch sessions componentDomain sid iqID from payload
		(fmap Just) <$> lookupAndStepSession setRouteJid clearSwitch setAllowJidDiscovery sessions componentDomain sid iqID from payload
	| otherwise = do
		now <- getCurrentTime
		existingRoute <- getRouteJid from
		possibleRoute <- getPossibleRoute from
		possibleSwitch <- getPossibleSwitch from
		allowJidDiscovery <- getAllowJidDiscovery 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)
				return (Map.insert sid (session, allowJidDiscovery, 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)
				return (Map.insert sid (session, allowJidDiscovery, now) sessions, Just $ stage1 possibleRoute existingRoute from iqID sid)
	where
	payload
		| Just p <- realPayload,


@@ 81,13 84,13 @@ processOneIQ componentDomain getPossibleRoute getPossibleSwitch getRouteJid setR
		| 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 :: 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 =
lookupAndStepSession :: SetRouteJid -> ClearSwitch -> SetAllowJidDiscovery -> Map SessionID (Session, Maybe Bool, UTCTime) -> Session' (IO (Map SessionID (Session, Maybe Bool, UTCTime), XMPP.IQ))
lookupAndStepSession setRouteJid clearSwitch setAllowJidDiscovery sessions componentDomain sid iqID from payload
	| Just (stepSession, allowJidDiscovery, _) <- Map.lookup sid sessions =
		case attributeText (s"action") payload of
			Just action | action == s"cancel" ->
				return (Map.delete sid sessions, (XMPP.emptyIQ XMPP.IQResult) {


@@ 124,20 127,24 @@ lookupAndStepSession setRouteJid clearSwitch sessions componentDomain sid iqID f
						]
				})
			_ ->
				let (session', iq) = stepSession componentDomain sid iqID from payload in
				let (session', iq) = stepSession allowJidDiscovery componentDomain sid iqID from payload in
				fmap (flip (,) iq) $ case session' of
					SessionNext s -> do
						now <- getCurrentTime
						return $! Map.insert sid (s, now) sessions
						return $! Map.insert sid (s, allowJidDiscovery, now) sessions
					SessionCancel -> return $! Map.delete sid sessions
					SessionSaveAndNext userJid gatewayJid s -> do
						now <- getCurrentTime
						userJid `setRouteJid` (Just gatewayJid)
						return $! Map.insert sid (s, now) sessions
						return $! Map.insert sid (s, allowJidDiscovery, now) sessions
					SessionAllowJidDiscovery userJid allow maybeNext -> do
						now <- getCurrentTime
						userJid `setAllowJidDiscovery` allow
						return $! Map.alter (const $ fmap (\s -> (s, allowJidDiscovery, now)) maybeNext) sid sessions
					SessionClearSwitchAndNext userJid s -> do
						now <- getCurrentTime
						clearSwitch userJid
						return $! Map.insert sid (s, now) sessions
						return $! Map.insert sid (s, allowJidDiscovery, now) sessions
					SessionCompleteSwitch userJid oldJid gatewayJid -> do
						userJid `setRouteJid` Just gatewayJid
						oldJid `setRouteJid` Nothing


@@ 150,14 157,45 @@ lookupAndStepSession setRouteJid clearSwitch sessions componentDomain sid iqID f
		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 | SessionClearSwitchAndNext XMPP.JID Session | SessionCompleteSwitch XMPP.JID XMPP.JID XMPP.JID | 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) | SessionAllowJidDiscovery XMPP.JID Bool (Maybe Session)
type Session' a = XMPP.Domain -> SessionID -> Text -> XMPP.JID -> Element -> a
type Session = Session' (SessionResult, XMPP.IQ)
type Session = Maybe Bool -> Session' (SessionResult, XMPP.IQ)

data RegisterFormType = DataForm | LegacyRegistration

jidDiscoveryOptInParse :: (Text -> XMPP.IQ) -> Maybe Session -> Session
jidDiscoveryOptInParse nextIQ nextS _ _ sid iqID from command
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command,
	  Just allow <- parseBool =<< getFormField form (s"allow_jid_discovery") = (SessionAllowJidDiscovery from allow nextS, nextIQ iqID)
	| otherwise = (SessionCancel, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-payload"))

jidDiscoveryOptIn :: (Text -> XMPP.IQ) -> Maybe Session -> XMPP.JID -> SessionID -> Text -> Maybe Bool -> (Session, XMPP.IQ)
jidDiscoveryOptIn nextIQ nextS iqTo sid iqID allowJidDiscovery = (jidDiscoveryOptInParse nextIQ nextS, (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"Jabber ID Discoverability Opt-in"],
			NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [
				NodeContent $ ContentText $ concat [
					s"You may want to allow other users to discover your Jabber ID when all they know is your phone number. ",
					s"This can allow upgrading your contacts to end-to-end encryption, video calling, and other benefits of Jabber over time."
				]
			],
			NodeElement $ Element (fromString "{jabber:x:data}field") [
				(fromString "{jabber:x:data}type", [ContentText $ s"boolean"]),
				(fromString "{jabber:x:data}var", [ContentText $ s"allow_jid_discovery"]),
				(fromString "{jabber:x:data}label", [ContentText $ s"Allow others to discover your Jabber ID based on your phone number"])
			] [
				NodeElement $ Element (fromString "{jabber:x:data}value") [] [NodeContent $ ContentText $ if allowJidDiscovery == Just False then s"false" else s"true"]
			]
		]
})

stage5 :: Text -> XMPP.JID -> Session
stage5 stage4iqID stage4from _ sid iqID from error
stage5 stage4iqID stage4from allowJidDiscovery _ sid iqID from error
	| elementName error == s"{jabber:component:accept}error" =
		(SessionCancel, (XMPP.emptyIQ XMPP.IQError) {
			XMPP.iqID = Just stage4iqID,


@@ 165,8 203,8 @@ stage5 stage4iqID stage4from _ sid iqID from error
			XMPP.iqPayload = Just error
		})
	| otherwise =
		(SessionComplete stage4from (Just from), (XMPP.emptyIQ XMPP.IQResult) {
			XMPP.iqID = Just stage4iqID,
		let (next, iq) = jidDiscoveryOptIn (\iqID' -> (XMPP.emptyIQ XMPP.IQResult) {
			XMPP.iqID = Just iqID',
			XMPP.iqTo = Just stage4from,
			XMPP.iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command")
				[


@@ 181,10 219,12 @@ stage5 stage4iqID stage4from _ sid iqID from error
						NodeContent $ ContentText $ s"Registration complete."
					]
				]
		})
		}) Nothing stage4from sid stage4iqID allowJidDiscovery
		in
		(SessionSaveAndNext stage4from from next, iq)

stage4 :: RegisterFormType -> XMPP.JID -> Session
stage4 formType gatewayJid componentDomain sid iqID from command
stage4 formType gatewayJid _ componentDomain sid iqID from command
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command =
		(SessionNext $ stage5 iqID from, (XMPP.emptyIQ XMPP.IQSet) {
			XMPP.iqID = Just (s"ConfigureDirectMessageRoute4" ++ sessionIDToText sid),


@@ 200,7 240,7 @@ stage4 formType gatewayJid componentDomain sid iqID from command
	sendFrom = sendFromForBackend componentDomain from

stage3 :: Text -> XMPP.JID -> Session
stage3 stage2iqID stage2from _ sid iqID from query
stage3 stage2iqID stage2from _ _ sid iqID from query
	| elementName query == s"{jabber:component:accept}error" =
		(SessionCancel, (XMPP.emptyIQ XMPP.IQError) {
			XMPP.iqID = Just stage2iqID,


@@ 223,7 263,7 @@ stage3 stage2iqID stage2from _ sid iqID from query
		})

stage2 :: Session
stage2 componentDomain sid iqID from command
stage2 _ componentDomain sid iqID from command
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command,
	  Just gatewayJid <- XMPP.parseJID =<< getFormField form (s"gateway-jid"),
	  XMPP.jidNode gatewayJid == Nothing && XMPP.jidResource gatewayJid == Nothing =


@@ 255,7 295,7 @@ stage2 componentDomain sid iqID from command
	| otherwise = (SessionCancel, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-payload"))
	where
	sendFrom = sendFromForBackend componentDomain from
	commandOrIBR gatewayJid _ _ _ _ command'
	commandOrIBR gatewayJid _ _ _ _ _ command'
		| (s"jabber:iq:register") `elem` mapMaybe (attributeText (s"node")) (isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren command') =
			(SessionNext $ proxyAdHocFromGateway iqID from, (XMPP.emptyIQ XMPP.IQSet) {
				XMPP.iqID = Just (s"ConfigureDirectMessageRoute2" ++ sessionIDToText sid),


@@ 274,32 314,33 @@ stage2 componentDomain sid iqID from command
-- Use SessionNext and SessionSaveAndNext to allow the proxied session to continue for prev
-- Rely on expiry for cleanup
proxyAdHocFromGateway :: Text -> XMPP.JID -> Session
proxyAdHocFromGateway prevIqID userJid _ sid iqID from command
	| attributeText (s"status") command == Just (s"canceled") = (SessionNext next, proxied)
proxyAdHocFromGateway prevIqID userJid allowJidDiscovery _ sid iqID from command
	| attributeText (s"status") command == Just (s"canceled") = (SessionNext next, proxied prevIqID)
	| 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
			(SessionNext next, proxied)
			(SessionNext next, proxied prevIqID)
		else
			(
				SessionSaveAndNext userJid from next,
				proxied {
					XMPP.iqPayload = fmap (\elem ->
						elem {
							XML.elementNodes = XML.elementNodes elem ++ [
								XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/commands}note")
									[(s"type", [XML.ContentText $ s"info"])]
									[XML.NodeContent $ XML.ContentText $ s"Registration complete."]
							]
						}
					) (XMPP.iqPayload proxied)
				}
			)
	| otherwise = (SessionNext next, proxied)
			let (next', iq) = jidDiscoveryOptIn (\iqid ->
					(proxied iqid) {
						XMPP.iqPayload = fmap (\elem ->
							elem {
								XML.elementNodes = XML.elementNodes elem ++ [
									XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/commands}note")
										[(s"type", [XML.ContentText $ s"info"])]
										[XML.NodeContent $ XML.ContentText $ s"Registration complete."]
								]
							}
						) (XMPP.iqPayload $ proxied iqid)
					}
				) (Just next) userJid sid prevIqID allowJidDiscovery
			in
			(SessionSaveAndNext userJid from next', iq)
	| otherwise = (SessionNext next, proxied prevIqID)
	where
	next = proxyAdHocFromUser iqID otherSID from
	proxied =
	proxied iqid =
		(XMPP.emptyIQ XMPP.IQResult) {
			XMPP.iqID = Just prevIqID,
			XMPP.iqID = Just iqid,
			XMPP.iqTo = Just userJid,
			XMPP.iqPayload = Just $ command {
				XML.elementAttributes = map (\attr@(name, _) ->


@@ 313,7 354,7 @@ proxyAdHocFromGateway prevIqID userJid _ sid iqID from command
	otherSID = fromMaybe mempty $ XML.attributeText (s"sessionid") command

proxyAdHocFromUser :: Text -> Text -> XMPP.JID -> Session
proxyAdHocFromUser prevIqID otherSID gatewayJid componentDomain _ iqID from command = (
proxyAdHocFromUser prevIqID otherSID gatewayJid _ componentDomain _ iqID from command = (
		SessionNext $ proxyAdHocFromGateway iqID from,
		(XMPP.emptyIQ XMPP.IQSet) {
			XMPP.iqID = Just prevIqID,


@@ 359,7 400,7 @@ switchStage1 newJid switchJid switchRoute possibleRoute existingRoute iqTo iqID 
}

switchStage2 :: XMPP.JID -> XMPP.JID -> Maybe XMPP.JID -> Maybe XMPP.JID -> Session
switchStage2 switchJid switchRoute possibleRoute existingRoute componentDomain sid iqID from command
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") =
		(


@@ 378,7 419,7 @@ switchStage2 switchJid switchRoute possibleRoute existingRoute componentDomain s
		)

switchStage3 :: XMPP.JID -> XMPP.JID -> Text -> XMPP.JID -> Session
switchStage3 switchJid switchRoute stage2ID stage2From componentDomain sid iqID from command
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" =


@@ 407,7 448,7 @@ switchStage3 switchJid switchRoute stage2ID stage2From componentDomain sid iqID 
	| 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
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

M Main.hs => Main.hs +8 -0
@@ 2242,6 2242,14 @@ main = do
					let userJid' = maybeUnescape componentJid userJid in
					DB.del db (DB.byJid userJid' ["jidSwitch"])
				)
				(\userJid ->
					let userJid' = maybeUnescape componentJid userJid in
					DB.getEnum db (DB.byJid userJid' ["allowJidDiscovery"])
				)
				(\userJid allow ->
					let userJid' = maybeUnescape componentJid userJid in
					DB.setEnum db (DB.byJid userJid' ["allowJidDiscovery"]) allow
				)

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