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

@@ 10,6 10,7 @@ packages:
 - libgnutls28-dev
 - libgsasl7-dev
 - libpcre3-dev
+- libssl-dev
 - libtokyocabinet-dev
 - libxml2-dev
 - zlib1g-dev

@@ 10,6 10,7 @@ packages:
 - libgnutls28-dev
 - libgsasl7-dev
 - libpcre3-dev
+- libssl-dev
 - libtokyocabinet-dev
 - libxml2-dev
 - zlib1g-dev

@@ 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"

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

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

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