From f844e3136f0021c382874bd89a57de52ad4c92b4 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Tue, 17 Sep 2024 10:10:07 -0500 Subject: [PATCH] Initital WebXDC attachment must head the thread So that in reply to all match up properly --- Email.hs | 44 +++++++++++---- test/EmailTest.hs | 137 +++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 168 insertions(+), 13 deletions(-) diff --git a/Email.hs b/Email.hs index b50f823..643c745 100644 --- a/Email.hs +++ b/Email.hs @@ -448,17 +448,26 @@ typeHeaders XMPP.Message { XMPP.messageType = XMPP.MessageChat } = set (MIME.headers . at (s"Chat-Version")) (Just $ s"1.0") typeHeaders _ = id -mkMessageID :: MIME.Domain -> UTCTime -> XMPP.Message -> ByteString -mkMessageID domain now message = ((s"<" ++) . (++ s">")) $ + +mkMessageID' :: MIME.Domain -> UTCTime -> String -> String -> ByteString +mkMessageID' domain now sid thread = ((s"<" ++) . (++ s">")) $ MIME.renderAddressSpec $ MIME.AddrSpec (fromString $ time ++ "." ++ sid ++ "." ++ thread) domain where - sid = maybe "=00" equalsEncode $ XMPP.stanzaID message - thread = - maybe "=00" (equalsEncode . mconcat . XML.elementText) $ - child (s"{jabber:component:accept}thread") message time = formatTime defaultTimeLocale "%s" now +mkMessageID :: MIME.Domain -> UTCTime -> XMPP.Message -> ByteString +mkMessageID domain now message = + mkMessageID' domain now sid thread + where + sid = maybe "=00" equalsEncode $ XMPP.stanzaID message + thread = fromMaybe "=00" $ mkThread message + +mkThread :: XMPP.Message -> Maybe String +mkThread message = + equalsEncode . mconcat . XML.elementText <$> + child (s"{jabber:component:accept}thread") message + mkReferences :: XMPP.Message -> Maybe ByteString mkReferences = fmap (limitReferencesLength . encodeUtf8) . @@ -620,15 +629,20 @@ messageToEmailIO domain message = do attachments <- messageToAttachments message now <- fromIO_ getCurrentTime let mime = messageToMIME boundaries attachments message - return $ messageToEmail domain now message =<< mime + let xdc = any (matchWebXDC . mimeType) attachments + return $ messageToEmail domain now xdc message =<< mime + +matchWebXDC :: MIME.ContentType -> Bool +matchWebXDC = MIME.matchContentType (s"application") (Just $ s"webxdc+zip") messageToEmail :: MIME.Domain -> UTCTime + -> Bool -> XMPP.Message -> MIME.MIMEMessage -> Either XMPP.Message EmailWithEnvelope -messageToEmail fromDomain now message@XMPP.Message { +messageToEmail fromDomain now threadHead message@XMPP.Message { XMPP.messageFrom = Just from, XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _) } mime | Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode = @@ -655,9 +669,17 @@ messageToEmail fromDomain now message@XMPP.Message { ) message where - mid = mkMessageID fromDomain now message + mid + | threadHead = mkMessageID fromDomain epoch + (message { XMPP.messageID = Nothing }) + | otherwise = mkMessageID fromDomain now message inreplyto = (lastZ . C8.words) =<< refs - refs = mkReferences message + refs = mkReferences message <|> + mfilter (const $ not threadHead) (fmap + (mkMessageID' fromDomain epoch "=00") + (mkThread message) + ) + Just epoch = parseXMPPTime (s"1970-01-01T00:00:00Z") jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from) dateHeader = utcToZonedTime utc $ fromMaybe now $ parseXMPPTime =<< XML.attributeText (s"stamp") =<< @@ -670,7 +692,7 @@ messageToEmail fromDomain now message@XMPP.Message { parsedToNode = MIME.parse (MIME.mailbox MIME.defaultCharsets) unescapedToNode unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode -messageToEmail _ _ message _ = Left $ +messageToEmail _ _ _ message _ = Left $ messageError (errorPayload "modify" "bad-request" (s"Could not process message") []) message diff --git a/test/EmailTest.hs b/test/EmailTest.hs index 867d213..82529d7 100644 --- a/test/EmailTest.hs +++ b/test/EmailTest.hs @@ -69,8 +69,10 @@ messageToEmailTest :: -> XMPP.Message -> Either XMPP.Message EmailWithEnvelope messageToEmailTest d now as m = - messageToEmail d now m =<< + messageToEmail d now xdc m =<< messageToMIME (boundary1, boundary2) as m + where + xdc = any (matchWebXDC . mimeType) as unit_emailToStanzaSimple :: IO () unit_emailToStanzaSimple = @@ -832,6 +834,8 @@ unit_messageToEmailWithThread = timestamp = Time.formatTime Time.defaultTimeLocale "%s" date email = s$"MIME-Version: 1.0\r\n\ \Message-ID: <" ++ timestamp ++ ".=00.athread@gateway.example.com>\r\n\ + \References: <0.=00.athread@gateway.example.com>\r\n\ + \In-Reply-To: <0.=00.athread@gateway.example.com>\r\n\ \To: t@example.com\r\n\ \From: f \r\n\ \Jabber-ID: f@example.com\r\n\ @@ -1013,6 +1017,135 @@ unit_messageToEmailWebXDCUpdate = ] } +unit_messageToEmailWebXDCUpdateXMPPThread :: IO () +unit_messageToEmailWebXDCUpdateXMPPThread = + hush (fmap (MIME.renderMessage . emailMessage) ( + messageToEmailTest + (MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com") + date + [] + message + )) + @?= + Just email + where + Just date = parseXMPPTime (s"1990-01-01T00:00:00Z") + timestamp = Time.formatTime Time.defaultTimeLocale "%s" date + email = s$"MIME-Version: 1.0\r\n\ + \Message-ID: <" ++ timestamp ++ ".=00.xt@gateway.example.com>\r\n\ + \References: <0.=00.xt@gateway.example.com>\r\n\ + \In-Reply-To: <0.=00.xt@gateway.example.com>\r\n\ + \To: t@example.com\r\n\ + \From: f \r\n\ + \Jabber-ID: f@example.com\r\n\ + \Date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\ + \Content-Type: multipart/mixed; boundary=b1\r\n\r\n\ + \--b1\r\n\ + \MIME-Version: 1.0\r\n\ + \Content-Type: multipart/report; \ + \report-type=status-update; boundary=b2\r\n\r\n\ + \--b2\r\n\ + \MIME-Version: 1.0\r\n\ + \Content-Transfer-Encoding: 7bit\r\n\ + \Content-Disposition: inline\r\n\ + \Content-Type: text/plain; charset=us-ascii\r\n\r\n\ + \WebXDC update\r\n\ + \--b2\r\n\ + \MIME-Version: 1.0\r\n\ + \Content-Transfer-Encoding: 7bit\r\n\ + \Content-Disposition: attachment; filename=status-update.json\r\n\ + \Content-Type: application/json\r\n\r\n\ + \{\"updates\":[{\"document\":\"some document\",\"payload\":{}\ + \,\"summary\":\"some summary\",\"info\":\"some info\"}]}\r\n\ + \--b2--\r\n\r\n\ + \--b1--\r\n" + message = (XMPP.emptyMessage XMPP.MessageNormal) { + XMPP.messageTo = + XMPP.parseJID $ s"t\\40example.com@gateway.example.com", + XMPP.messageFrom = XMPP.parseJID $ s"f@example.com", + XMPP.messagePayloads = [ + XML.Element (s"{jabber:component:accept}body") + [] [XML.NodeContent $ XML.ContentText $ s"some info"], + XML.Element (s"{urn:xmpp:webxdc:0}x") [] [ + XML.NodeElement $ XML.Element + (s"{urn:xmpp:webxdc:0}document") [] [ + XML.NodeContent $ XML.ContentText $ + s"some document" + ], + XML.NodeElement $ + XML.Element (s"{urn:xmpp:webxdc:0}summary") [] [ + XML.NodeContent $ XML.ContentText $ + s"some summary" + ], + XML.NodeElement $ + XML.Element (s"{urn:xmpp:json:0}json") [] [ + XML.NodeContent $ XML.ContentText $ + s"{}" + ] + ], + XML.Element (s"{jabber:component:accept}thread") [] [ + XML.NodeContent $ XML.ContentText $ + s"xt" + ] + ] + } + +unit_messageToEmailWebXDC :: IO () +unit_messageToEmailWebXDC = + hush (fmap (MIME.renderMessage . emailMessage) ( + messageToEmailTest + (MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com") + date + attachments + message + )) + @?= + Just email + where + Just date = parseXMPPTime (s"1990-01-01T00:00:00Z") + email = s"MIME-Version: 1.0\r\n\ + \Message-ID: <0.=00.xmppthread@gateway.example.com>\r\n\ + \To: t@example.com\r\n\ + \From: f \r\n\ + \Jabber-ID: f@example.com\r\n\ + \Date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\ + \Content-Type: multipart/mixed; boundary=b1\r\n\r\n\ + \--b1\r\n\ + \MIME-Version: 1.0\r\n\ + \Content-Transfer-Encoding: 7bit\r\n\ + \Content-Disposition: inline\r\n\ + \Content-Type: text/plain; charset=us-ascii\r\n\r\n\ + \the body\r\n\ + \--b1\r\n\ + \MIME-Version: 1.0\r\n\ + \Content-Transfer-Encoding: 7bit\r\n\ + \Content-Disposition: attachment; filename=widget.xdc\r\n\ + \Content-Type: application/webxdc+zip\r\n\r\n\ + \data\r\n\ + \--b1--\r\n" + attachments = [ + Attachment + (MIME.ContentType + (s"application") (s"webxdc+zip") mempty) + (s"widget.xdc") + (s"data") + ] + message = (XMPP.emptyMessage XMPP.MessageNormal) { + XMPP.messageID = Just $ s"sid", + XMPP.messageTo = + XMPP.parseJID $ s"t\\40example.com@gateway.example.com", + XMPP.messageFrom = XMPP.parseJID $ s"f@example.com", + XMPP.messagePayloads = [ + XML.Element (s"{jabber:component:accept}body") [] [ + XML.NodeContent $ s"the body" + ], + XML.Element (s"{jabber:component:accept}thread") [] [ + XML.NodeContent $ XML.ContentText $ + s"xmppthread" + ] + ] + } + unit_messageToEmailAttachment :: IO () unit_messageToEmailAttachment = hush (fmap (MIME.renderMessage . emailMessage) ( @@ -1051,7 +1184,7 @@ unit_messageToEmailAttachment = Attachment MIME.contentTypeApplicationOctetStream (s"afile.bin") - (s"data") + (s"data") ] message = (XMPP.emptyMessage XMPP.MessageNormal) { XMPP.messageTo = -- 2.45.2