4 files changed, 169 insertions(+), 7 deletions(-)

M Main.hs
M Makefile
A Tapback.hs
M cheogram.cabal

@@ 39,7 39,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Map as Map
 import qualified Data.Map.Strict as SMap
-import qualified Data.UUID as UUID ( toString )
+import qualified Data.UUID as UUID ( toString, toText )
 import qualified Data.UUID.V1 as UUID ( nextUUID )
 import qualified Data.ByteString.Lazy as LZ
 import qualified Data.ByteString as BS


@@ 58,6 58,7 @@ import qualified ConfigureDirectMessageRoute
 import qualified JidSwitch
 import qualified Config
 import qualified DB
+import qualified Tapback
 import qualified VCard4
 import Adhoc (adhocBotSession, commandList, queryCommandList)
 import StanzaRec


@@ 482,6 483,48 @@ componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoo
 	strippedM = mapBody (const strippedBody) m
 	strippedBody = stripOtrWhitespace body
 	extra = T.unpack $ escapeJid $ T.pack $ show (fromMaybe mempty (messageID m), maybe mempty strResource $ jidResource from)
+componentMessage db componentJid m@(Message { messageTo = Just to, messagePayloads = payloads }) existingRoom from smsJid _
+	| [reactions] <- XML.isNamed (s"{urn:xmpp:reactions:0}reactions") =<< payloads,
+	  Just rid <- XML.attributeText (s"id") reactions = do
+		case XML.isNamed (s"{urn:xmpp:reactions:0}reaction") =<< XML.elementChildren reactions of
+			[reaction] -> do
+				mrbody <- DB.get db (DB.byJid from ["body", textToString rid])
+				case mrbody of
+					Nothing -> return [
+							mkStanzaRec $ m { messageTo = Just from, messageFrom = Just to, messageType = MessageError, messagePayloads =
+								(Element (s"{jabber:component:accept}error")
+										[(s"{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
+										[
+											NodeElement $ Element (s"{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable") [] [],
+											NodeElement $ Element (s"{urn:ietf:params:xml:ns:xmpp-stanzas}text")
+												[(fromString "xml:lang", [ContentText $ fromString "en"])]
+												[NodeContent $ ContentText $ s"Could not find message to react to"]
+										]
+								) : payloads
+							}
+						]
+					Just rbody -> do
+						componentMessage db componentJid (m {
+							messagePayloads =
+								(XML.Element (s"{jabber:component:accept}body") [] []) :
+								XML.Element (s"{urn:xmpp:fallback:0}fallback") [(s"for", [s"urn:xmpp:reactions:0"])] [
+									XML.NodeElement $ mkElement (s"{urn:xmpp:fallback:0}body") (s"")
+								] : payloads
+						}) existingRoom from smsJid $ Just $
+							Tapback.smsBody $ Tapback.fromReaction (mconcat $ XML.elementText reaction) rbody
+			_ -> return [
+					mkStanzaRec $ m { messageTo = Just from, messageFrom = Just to, messageType = MessageError, messagePayloads =
+						(Element (s"{jabber:component:accept}error")
+								[(s"{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
+								[
+									NodeElement $ Element (s"{urn:ietf:params:xml:ns:xmpp-stanzas}not-acceptable") [] [],
+									NodeElement $ Element (s"{urn:ietf:params:xml:ns:xmpp-stanzas}text")
+										[(fromString "xml:lang", [ContentText $ fromString "en"])]
+										[NodeContent $ ContentText $ s"Tapback must be exactly one reaction"]
+								]
+						) : payloads
+					}
+				]
 componentMessage _ _ m _ _ _ _ = do
 	log "UNKNOWN MESSAGE" m
 	return []


@@ 632,11 675,11 @@ data ComponentContext = ComponentContext {
 }
 
 componentStanza :: ComponentContext -> ReceivedStanza -> IO [StanzaRec]
-componentStanza (ComponentContext { adhocBotMessage, ctxCacheOOB, componentJid }) (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }) }))
+componentStanza (ComponentContext { db, adhocBotMessage, ctxCacheOOB, componentJid }) (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }) }))
 	| Just reply <- groupTextPorcelein (formatJID componentJid) m = do
 		-- TODO: only when from direct message route
 		-- TODO: only if target does not understand stanza addressing
-		Just reply' <- fmap (groupTextPorcelein (formatJID componentJid)) $ UIO.lift $ ctxCacheOOB True m
+		Just reply' <- fmap (groupTextPorcelein (formatJID componentJid)) $ UIO.lift $ rememberIncomingBody db =<< ctxCacheOOB True m
 		return [mkStanzaRec reply']
 	| MessageError == messageType m = return []
 	| Just _ <- getBody "jabber:component:accept" m = do


@@ 664,6 707,7 @@ componentStanza _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom
 componentStanza (ComponentContext { db, smsJid = (Just smsJid), componentJid, ctxCacheOOB }) (ReceivedMessage (m@Message { messageTo = Just to@(JID { jidNode = Just _ }), messageFrom = Just from})) = do
 	existingRoom <- (parseJID =<<) <$> DB.get db (DB.byNode to ["joined"])
 	m' <- UIO.lift $ ctxCacheOOB False m
+	UIO.lift $ rememberOutgoingBody db m'
 	componentMessage db componentJid m' existingRoom from smsJid $
 		getBody "jabber:component:accept" m'
 componentStanza (ComponentContext { smsJid = (Just smsJid), toRejoinManager, componentJid }) (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id }))


@@ 1139,6 1183,45 @@ participantJid payloads =
 	elementChildren =<<
 	isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads
 
+-- Tapbacks reference messages using the whole body, so we need to remember message id, body pairs temporarily for them to work
+rememberIncomingBody :: (Unexceptional m) => DB.DB -> Message -> m Message
+rememberIncomingBody db m@(XMPP.Message { XMPP.messageTo = Just to, XMPP.messagePayloads = payloads })
+	| Just body <- getBody "jabber:component:accept" m,
+	  Just tapback <- Tapback.parse body = do
+		mrid <- fmap (join . hush) $ UIO.fromIO $ DB.get db (DB.byJid to ["body", showDigest $ sha1 $ LZ.fromStrict $ encodeUtf8 $ Tapback.body tapback])
+		case mrid of
+			Nothing -> return m
+			Just rid -> return $ m {
+					XMPP.messagePayloads = payloads ++ [
+						XML.Element (s"{urn:xmpp:reactions:0}reactions") [(s"id", [XML.ContentText rid])] [
+							XML.NodeElement $ mkElement (s"{urn:xmpp:reactions:0}reaction") (Tapback.emoji tapback)
+						]
+					]
+				}
+rememberIncomingBody db m@(XMPP.Message { XMPP.messageTo = Just to })
+	| Just body <- getBody "jabber:component:accept" m = do
+		mid <- midGenerator
+		void $ UIO.fromIO $ do -- ignore db failure
+			DB.set db (DB.byJid to ["body", textToString mid]) body
+			DB.expire db (DB.byJid to ["body", textToString mid]) 3600
+		return $ m { XMPP.messageID = Just mid }
+	where
+	midGenerator
+		| Just originalId <- XMPP.messageID m = return originalId
+		| otherwise = fromIO_ $ fmap (fromMaybe mempty) $ (fmap . fmap) UUID.toText UUID.nextUUID
+rememberIncomingBody _ m = return m
+
+rememberOutgoingBody :: (Unexceptional m) => DB.DB -> Message -> m ()
+rememberOutgoingBody db m@(XMPP.Message { XMPP.messageFrom = Just from, XMPP.messageID = Just mid })
+	| Just body <- getBody "jabber:component:accept" m =
+		let
+			hash = showDigest $ sha1 $ LZ.fromStrict $ encodeUtf8 body
+		in
+		void $ UIO.fromIO $ do -- ignore db failure
+			DB.set db (DB.byJid from ["body", hash]) mid
+			DB.expire db (DB.byJid from ["body", hash]) 3600
+rememberOutgoingBody _ _ = return ()
+
 cacheHTTP :: (Unexceptional m) => FilePath -> Text -> m (Either IOError (FilePath, Digest SHA1, Digest SHA256, Digest SHA512))
 cacheHTTP jingleStore url =
 	UIO.fromIO' (userError . show) $


@@ 1401,6 1484,7 @@ component db redis pushStatsd backendHost did maybeAvatar cacheOOB sendIQ iqRece
 								] []
 							) multipleTo
 						] }
+					UIO.lift $ rememberOutgoingBody db m'
 					-- TODO: should check if backend supports XEP-0033
 					-- TODO: fallback for no-backend case should work
 					mapM_ sendToComponent =<< componentMessage db componentJid m' Nothing from backendJid (getBody "jabber:component:accept" m')


@@ 1452,7 1536,7 @@ component db redis pushStatsd backendHost did maybeAvatar cacheOOB sendIQ iqRece
 							  Just from' <- XMPP.parseJID $ (intercalate (s",") $ sort $ mapMaybe (T.stripPrefix (s"sms:") <=< XML.attributeText (s"uri")) (isNamed (s"{http://jabber.org/protocol/address}address") =<< elementChildren addresses)) ++ s"@" ++ formatJID componentJid ->
 								sendToComponent $ receivedStanza $ receivedStanzaFromTo from' routeTo stanza
 							| route == strDomain (jidDomain from) ->
-								(sendToComponent . receivedStanza) =<< mapReceivedMessageM (UIO.lift . cacheOOB True) (receivedStanzaFromTo componentFrom routeTo stanza)
+								(sendToComponent . receivedStanza) =<< mapReceivedMessageM (UIO.lift . (rememberIncomingBody db <=< cacheOOB True)) (receivedStanzaFromTo componentFrom routeTo stanza)
 						(Just route, _) -- Alphanumeric senders
 							| route == strDomain (jidDomain from),
 							  Just localpart <- strNode <$> jidNode from,

@@ 5,10 5,10 @@ HLINTFLAGS=-XHaskell2010 -XCPP -i 'Use camelCase' -i 'Use String' -i 'Use head' 
 
 all: report.html cheogram
 
-cheogram: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs JidSwitch.hs VCard4.hs
+cheogram: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs JidSwitch.hs VCard4.hs Tapback.hs
 	ghc -dynamic -package monads-tf -o cheogram $(GHCFLAGS) Main.hs
 
-report.html: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs JidSwitch.hs VCard4.hs
+report.html: Main.hs Adhoc.hs Config.hs ConfigureDirectMessageRoute.hs DB.hs IQManager.hs RedisURL.hs StanzaRec.hs UniquePrefix.hs Util.hs JidSwitch.hs VCard4.hs Tapback.hs
 	-hlint $(HLINTFLAGS) --report $^
 
 shell:

@@ 0,0 1,78 @@
+module Tapback where
+
+import Prelude ()
+import BasicPrelude
+
+import Control.Error (hush)
+import qualified Data.Text as Text
+import qualified Data.Attoparsec.Text as Atto
+
+import Util
+
+data Tapback =
+	Liked Text |
+	Disliked Text |
+	Loved Text |
+	Laughed Text |
+	Emphasized Text |
+	Questioned Text |
+	Reacted Text Text
+	deriving (Show)
+
+body :: Tapback -> Text
+body (Liked body) = body
+body (Disliked body) = body
+body (Loved body) = body
+body (Laughed body) = body
+body (Emphasized body) = body
+body (Questioned body) = body
+body (Reacted _ body) = body
+
+emoji :: Tapback -> Text
+emoji (Liked _) = s"👍"
+emoji (Disliked _) = s"👎"
+emoji (Loved _) = s"❤"
+emoji (Laughed _) = s"😂"
+emoji (Emphasized _) = s"❗"
+emoji (Questioned _) = s"❓"
+emoji (Reacted emoji _) = emoji
+
+parse :: Text -> Maybe Tapback
+parse = hush . Atto.parseOnly parser
+
+parser :: Atto.Parser Tapback
+parser =
+	(
+		Atto.string (s"Liked") *> pure Liked <|>
+		Atto.string (s"Disliked") *> pure Disliked <|>
+		Atto.string (s"Loved") *> pure Loved <|>
+		Atto.string (s"Laughed at") *> pure Laughed <|>
+		Atto.string (s"Emphasized") *> pure Emphasized <|>
+		Atto.string (s"Questioned") *> pure Emphasized <|>
+		Atto.string (s"Reacted with ") *> (Reacted <$> Atto.takeTill (==' ') <* Atto.string (s" to"))
+	) <*> (
+		Atto.char ' ' *> Atto.char '“' *>
+		Atto.takeTill (=='”') <* Atto.char '”'
+	)
+
+fromReaction :: Text -> Text -> Tapback
+fromReaction reaction body
+	| emoji == s"👍" = Liked body
+	| emoji == s"👎" = Disliked body
+	| emoji == s"❤" = Loved body
+	| emoji == s"😂" = Laughed body
+	| emoji == s"❗" = Emphasized body
+	| emoji == s"❓" = Questioned body
+	| otherwise = Reacted reaction body
+	where
+	-- Emoji variant selector optional
+	emoji = Text.dropWhileEnd (=='\xFE0F') reaction
+
+smsBody :: Tapback -> Text
+smsBody (Liked body) = s"Liked “" ++ body ++ s"”"
+smsBody (Disliked body) = s"Disliked “" ++ body ++ s"”"
+smsBody (Loved body) = s"Loved “" ++ body ++ s"”"
+smsBody (Laughed body) = s"Laughed at “" ++ body ++ s"”"
+smsBody (Emphasized body) = s"Emphasized “" ++ body ++ s"”"
+smsBody (Questioned body) = s"Questioned “" ++ body ++ s"”"
+smsBody (Reacted emoji body) = s"Reacted with " ++ emoji ++ s" to “" ++ body ++ s"”"

@@ 21,7 21,7 @@ extra-source-files:
 
 executable cheogram
         main-is: Main.hs
-        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc, Config, DB, JidSwitch, VCard4
+        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc, Config, DB, JidSwitch, Tapback, VCard4
         default-language: Haskell2010
         ghc-options:      -Wall -Wno-tabs -Wno-orphans -Wno-name-shadowing -O -threaded