~singpolyma/cheogram

7385a44116380706e82c18f879d8979708fcfcbe — Stephen Paul Weber 1 year, 10 months ago 0070953
Set up structure to cache OOB coming from a direct message route

Does not actually fetch or cache any OOB data yet, but detects all such data and
has the right types to be able to do it. Replaces all OOB elements with new ones
and replaces all instances of gives URLs with new URLs, just no actual work is
done yet.
2 files changed, 45 insertions(+), 6 deletions(-)

M Main.hs
M Util.hs
M Main.hs => Main.hs +31 -5
@@ 24,6 24,7 @@ import qualified Network.StatsD as StatsD

import "monads-tf" Control.Monad.Error (catchError) -- ick
import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText, attributeContent, hasAttribute, nameNamespace)
import UnexceptionalIO (Unexceptional)
import qualified UnexceptionalIO as UIO
import qualified Dhall
import qualified Dhall.Core as Dhall hiding (Decoder)


@@ 629,11 630,12 @@ handleRegister _ _ iq _ = do
	log "HANDLEREGISTER UNKNOWN" iq
	return []

componentStanza db _ _ adhocBotMessage _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }), messageFrom = Just from}))
	| Just reply <- groupTextPorcelein (formatJID componentJid) m =
componentStanza db _ _ (adhocBotMessage, cacheOOB) _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }), messageFrom = Just from}))
	| Just reply <- groupTextPorcelein (formatJID componentJid) m = do
		-- TODO: only when from direct message route
		-- TODO: only if target does not understand stanza addressing
		return [mkStanzaRec reply]
		reply' <- cacheOOB reply
		return [mkStanzaRec reply']
	| Just body <- getBody "jabber:component:accept" m = do
		atomicUIO $ adhocBotMessage m
		return []


@@ 1023,6 1025,30 @@ participantJid payloads =
	elementChildren =<<
	isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads

cacheOneOOB :: (Unexceptional m) => XML.Element -> m ((Text, Text), XML.Element)
cacheOneOOB oob
	| [url] <- (mconcat . XML.elementText) <$> urls =
		return ((url, url), oob)
	| otherwise = do
		log "cacheOneOOB MALFORMED" oob
		return ((mempty, mempty), oob)
	where
	urlName = s"{jabber:x:oob}url"
	(urls, rest) = partition (\el -> XML.elementName el == urlName) (elementChildren oob)

cacheOOB :: (Unexceptional m) => XMPP.Message -> m XMPP.Message
cacheOOB m@(XMPP.Message { XMPP.messagePayloads = payloads }) = do
	(replacements, oobs') <- unzip <$> mapM cacheOneOOB oobs
	let body' =
		(mkElement bodyName .: foldl (\body (a, b) -> T.replace a b body)) <$>
		(map (mconcat . XML.elementText) body) <*> pure replacements
	return $ m { XMPP.messagePayloads = noOobsNoBody ++ oobs' ++ body' }
	where
	oobName = s"{jabber:x:oob}x"
	bodyName = s"{jabber:component:accept}body"
	(body, noOobsNoBody) = partition (\el -> XML.elementName el == bodyName) noOobs
	(oobs, noOobs) = partition (\el -> XML.elementName el == oobName) payloads

component db redis pushStatsd backendHost did adhocBotIQReceiver adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer toComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do
	sendThread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do
		stanza <- liftIO $ atomically $ readTChan toComponent


@@ 1170,7 1196,7 @@ component db redis pushStatsd backendHost did adhocBotIQReceiver adhocBotMessage
					maybeRoute <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0direct-message-route")
					case (fmap fromString maybeRoute, parseJID (unescapeJid localpart ++ toResourceSuffix), mapToComponent from) of
						(Just route, Just routeTo, Just componentFrom) | route == strDomain (jidDomain from) -> do
								sendToComponent $ mkStanzaRec $ receivedStanza $ receivedStanzaFromTo componentFrom routeTo stanza
							(sendToComponent . receivedStanza) =<< mapReceivedMessageM cacheOOB (receivedStanzaFromTo componentFrom routeTo stanza)
						_ | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to -> do
							sendToComponent $ stanzaError stanza $
								Element (fromString "{jabber:component:accept}error")


@@ 1197,7 1223,7 @@ component db redis pushStatsd backendHost did adhocBotIQReceiver adhocBotMessage
				  (nameNamespace $ elementName p) `elem` [Just (s"urn:xmpp:jingle:1"), Just (s"http://jabber.org/protocol/ibb")] -> do
					jingleHandler iq
				| otherwise -> liftIO $
					mapM_ sendToComponent =<< componentStanza db backendTo registrationJids adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza
					mapM_ sendToComponent =<< componentStanza db backendTo registrationJids (adhocBotMessage, cacheOOB jingleStore jingleStoreURL) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza
	where
	mapToComponent = mapToBackend (formatJID componentJid)
	sendToComponent = atomically . writeTChan toComponent

M Util.hs => Util.hs +14 -1
@@ 36,6 36,9 @@ log tag x = fromIO_ $ do
s :: (IsString a) => String -> a
s = fromString

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)

fromIO_ :: (Unexceptional m) => IO a -> m a
fromIO_ = fmap (either absurd id) . UIO.fromIO' (error . show)



@@ 218,7 221,7 @@ mkSMS :: XMPP.JID -> XMPP.JID -> Text -> XMPP.Message
mkSMS from to txt = (XMPP.emptyMessage XMPP.MessageChat) {
	XMPP.messageTo = Just to,
	XMPP.messageFrom = Just from,
	XMPP.messagePayloads = [XML.Element (fromString "{jabber:component:accept}body") [] [XML.NodeContent $ XML.ContentText txt]]
	XMPP.messagePayloads = [mkElement (s"{jabber:component:accept}body") txt]
}

castException :: (Ex.Exception e1, Ex.Exception e2) => e1 -> Maybe e2


@@ 237,3 240,13 @@ forkXMPP kid = do
	handler parent e
		| Just Ex.ThreadKilled <- castException e = return ()
		| otherwise = throwTo parent e

mkElement :: XML.Name -> Text -> XML.Element
mkElement name txt = XML.Element name [] [XML.NodeContent $ XML.ContentText txt]

mapReceivedMessageM :: (Applicative f) =>
	  (XMPP.Message -> f XMPP.Message)
	-> XMPP.ReceivedStanza
	-> f XMPP.ReceivedStanza
mapReceivedMessageM f (XMPP.ReceivedMessage m) = XMPP.ReceivedMessage <$> f m
mapReceivedMessageM _ s = pure s