~singpolyma/cheogram

5f9811f9b96858d7bf1db8195eea14fe728c4f16 — Stephen Paul Weber 7 days ago 2a39302 + fece856
Merge branch 'tapback'

* tapback:
  Support bidirectional reactions ("tapbacks") compatible with iMessage
4 files changed, 169 insertions(+), 7 deletions(-)

M Main.hs
M Makefile
A Tapback.hs
M cheogram.cabal
M Main.hs => Main.hs +88 -4
@@ 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,

M Makefile => Makefile +2 -2
@@ 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:

A Tapback.hs => Tapback.hs +78 -0
@@ 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"”"

M cheogram.cabal => cheogram.cabal +1 -1
@@ 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