~singpolyma/cheogram

e33fd0fd18379c2ce07e725bd21b49d220695782 — Stephen Paul Weber 1 year, 4 months ago 0070953 + 4a04ebf
Merge branch 'cache-inbound-oob'

* cache-inbound-oob:
  Intrument cacheOOB
  Fetch any OOB URL from route and cache in jingle store
  Set up structure to cache OOB coming from a direct message route
6 files changed, 89 insertions(+), 13 deletions(-)

M .builds/debian-stable.yml
M .builds/ubuntu-lts.yml
M Main.hs
M Makefile
M Util.hs
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 +69 -10
@@ 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)


@@ 24,10 24,12 @@ 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)
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


@@ 42,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


@@ 629,11 633,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,7 1028,59 @@ participantJid payloads =
	elementChildren =<<
	isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads

component db redis pushStatsd backendHost did adhocBotIQReceiver adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer toComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do
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) => ([StatsD.Stat] -> m ()) -> FilePath -> Text -> XML.Element -> m (Maybe (Text, Text), XML.Element)
cacheOneOOB pushStatsd jingleStore jingleStoreURL oob
	| [url] <- (mconcat . XML.elementText) <$> urls = do
		cacheResult <- cacheHTTP jingleStore url
		case cacheResult of
			Left err -> do
				pushStatsd [StatsD.stat ["cache", "oob", "failure"] 1 "c" Nothing]
				log "cacheOneOOB" err
				return (Nothing, oob)
			Right path ->
				pushStatsd [StatsD.stat ["cache", "oob", "success"] 1 "c" Nothing] >>
				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 (Nothing, oob)
	where
	urlName = s"{jabber:x:oob}url"
	(urls, rest) = partition (\el -> XML.elementName el == urlName) (elementChildren oob)

cacheOOB :: (Unexceptional m) => ([StatsD.Stat] -> m ()) -> FilePath -> Text -> XMPP.Message -> m XMPP.Message
cacheOOB pushStatsd jingleStore jingleStoreURL m@(XMPP.Message { XMPP.messagePayloads = payloads }) = do
	(replacements, oobs') <- unzip <$> mapM (cacheOneOOB pushStatsd jingleStore jingleStoreURL) oobs
	let body' =
		(mkElement bodyName .: foldl (\body (a, b) -> T.replace a b body)) <$>
		(map (mconcat . XML.elementText) body) <*> pure (catMaybes 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 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



@@ 1169,8 1226,8 @@ 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
								sendToComponent $ mkStanzaRec $ receivedStanza $ receivedStanzaFromTo componentFrom routeTo stanza
						(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 $
								Element (fromString "{jabber:component:accept}error")


@@ 1197,7 1254,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) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza
	where
	mapToComponent = mapToBackend (formatJID componentJid)
	sendToComponent = atomically . writeTChan toComponent


@@ 1972,8 2029,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 (UIO.lift . pushStatsd) 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 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

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,