~singpolyma/cheogram

d715d7de017b5e5c34a2958a9a58a953d34c00e8 — Stephen Paul Weber 2 years ago 7385a44
Fetch any OOB URL from route and cache in jingle store

Now we actually cache the data.  Always assumes URLs are HTTP, but they always
are in practise and if one is not it will simply fail and in case of any error
we just pass the oob element through unmodified.
5 files changed, 52 insertions(+), 17 deletions(-)

M .builds/debian-stable.yml
M .builds/ubuntu-lts.yml
M Main.hs
M Makefile
M cheogram.cabal
M .builds/debian-stable.yml => .builds/debian-stable.yml +1 -0
@@ 10,6 10,7 @@ packages:
- libgnutls28-dev
- libgsasl7-dev
- libpcre3-dev
- libssl-dev
- libtokyocabinet-dev
- libxml2-dev
- zlib1g-dev

M .builds/ubuntu-lts.yml => .builds/ubuntu-lts.yml +1 -0
@@ 10,6 10,7 @@ packages:
- libgnutls28-dev
- libgsasl7-dev
- libpcre3-dev
- libssl-dev
- libtokyocabinet-dev
- libxml2-dev
- zlib1g-dev

M Main.hs => Main.hs +46 -15
@@ 10,10 10,10 @@ import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ)
import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ, hush)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import Network.URI (parseURI, uriPath)
import Network.URI (parseURI, uriPath, escapeURIString)
import Network.HostAndPort (maybeHostAndPort)
import System.Random (Random(randomR), getStdRandom)
import System.Random.Shuffle (shuffleM)


@@ 29,6 29,7 @@ import qualified UnexceptionalIO as UIO
import qualified Dhall
import qualified Dhall.Core as Dhall hiding (Decoder)
import qualified Jingle
import qualified Jingle.StoreChunks as Jingle
import qualified Network.Socket as Socket
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T


@@ 43,6 44,8 @@ import qualified Data.ByteString.Builder as Builder
import qualified Database.TokyoCabinet as TC
import qualified Database.Redis as Redis
import qualified Text.Regex.PCRE.Light as PCRE
import qualified Network.Http.Client as HTTP
import qualified System.IO.Streams as Streams
import Network.Protocol.XMPP as XMPP -- should import qualified

import Util


@@ 1025,23 1028,49 @@ 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)
cacheHTTP :: (Unexceptional m) => FilePath -> Text -> m (Either IOError FilePath)
cacheHTTP jingleStore url =
		UIO.fromIO' (userError . show) $
		HTTP.get (encodeUtf8 url) $ \response body -> UIO.runEitherIO $
			if HTTP.getStatusCode response == 200 then
				fmap (fmap (\(fp,_,_,_) -> fp)) $
				Jingle.storeChunks Nothing jingleStore
				(escapeURIString isAlpha (textToString url))
				(hush <$> UIO.fromIO (fromMaybe mempty <$> Streams.read body))
			else
				return $ Left $ userError "Response was not 200 OK"

cacheOneOOB :: (Unexceptional m) => FilePath -> Text -> XML.Element -> m (Maybe (Text, Text), XML.Element)
cacheOneOOB jingleStore jingleStoreURL oob
	| [url] <- (mconcat . XML.elementText) <$> urls = do
		cacheResult <- cacheHTTP jingleStore url
		case cacheResult of
			Left err -> do
				log "cacheOneOOB" err
				return (Nothing, oob)
			Right path ->
				let url' = jingleStoreURL ++ (T.takeWhileEnd (/='/') $ fromString path) in
				return (
					Just (url, url'),
					oob {
						XML.elementNodes =
							map XML.NodeElement
							(mkElement urlName url' : rest)
					}
				)
	| otherwise = do
		log "cacheOneOOB MALFORMED" oob
		return ((mempty, mempty), oob)
		return (Nothing, 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
cacheOOB :: (Unexceptional m) => FilePath -> Text -> XMPP.Message -> m XMPP.Message
cacheOOB jingleStore jingleStoreURL m@(XMPP.Message { XMPP.messagePayloads = payloads }) = do
	(replacements, oobs') <- unzip <$> mapM (cacheOneOOB jingleStore jingleStoreURL) oobs
	let body' =
		(mkElement bodyName .: foldl (\body (a, b) -> T.replace a b body)) <$>
		(map (mconcat . XML.elementText) body) <*> pure replacements
		(map (mconcat . XML.elementText) body) <*> pure (catMaybes replacements)
	return $ m { XMPP.messagePayloads = noOobsNoBody ++ oobs' ++ body' }
	where
	oobName = s"{jabber:x:oob}x"


@@ 1049,7 1078,7 @@ cacheOOB m@(XMPP.Message { XMPP.messagePayloads = payloads }) = do
	(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
component db redis pushStatsd backendHost did cacheOOB 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



@@ 1195,7 1224,7 @@ component db redis pushStatsd backendHost did adhocBotIQReceiver adhocBotMessage
					let toResourceSuffix = maybe mempty (s"/"++) (strResource <$> jidResource to)
					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
						(Just route, Just routeTo, Just componentFrom) | route == strDomain (jidDomain from) ->
							(sendToComponent . receivedStanza) =<< mapReceivedMessageM cacheOOB (receivedStanzaFromTo componentFrom routeTo stanza)
						_ | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to -> do
							sendToComponent $ stanzaError stanza $


@@ 1223,7 1252,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, cacheOOB jingleStore jingleStoreURL) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza
					mapM_ sendToComponent =<< componentStanza db backendTo registrationJids (adhocBotMessage, cacheOOB) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza
	where
	mapToComponent = mapToBackend (formatJID componentJid)
	sendToComponent = atomically . writeTChan toComponent


@@ 1998,8 2027,10 @@ main = do
						}
				)

			let pushStatsd = void . UIO.fromIO . StatsD.push statsd

			log "" "runComponent STARTING"

			log "runComponent ENDED" =<< runComponent (Server componentJid host (PortNumber port)) secret
				(component db redis (void . UIO.fromIO . StatsD.push statsd) backendHost did adhocBotIQReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
				(component db redis (UIO.lift . pushStatsd) backendHost did (cacheOOB jingleStore jingleStoreURL) adhocBotIQReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
		_ -> log "ERROR" "Bad arguments"

M Makefile => Makefile +1 -1
@@ 1,4 1,4 @@
GHCFLAGS=-Wall -Wno-tabs -fno-warn-name-shadowing -XHaskell2010 -O2
GHCFLAGS=-Wall -Wno-tabs -Wno-orphans -Wno-name-shadowing -XHaskell2010 -O2 -threaded
HLINTFLAGS=-XHaskell2010 -XCPP -i 'Use camelCase' -i 'Use String' -i 'Use head' -i 'Use string literal' -i 'Use list comprehension'
VERSION=0.0.1


M cheogram.cabal => cheogram.cabal +3 -1
@@ 23,7 23,7 @@ executable cheogram
        main-is: Main.hs
        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc
        default-language: Haskell2010
        ghc-options:      -Wno-tabs -Wno-orphans
        ghc-options:      -Wall -Wno-tabs -Wno-orphans -Wno-name-shadowing -O2 -threaded

        build-depends:
                base == 4.*,


@@ 41,7 41,9 @@ executable cheogram
                HostAndPort,
                HTTP,
                http-types,
                http-streams,
                hstatsd,
                io-streams,
                jingle,
                monad-loops,
                monads-tf,