cheogram-smtp

Do not send empty emails for empty messages rss
created pr with cheogram-smtp/ignore-empty.1 on 2026-10-21T15:32:06Z · by 9e834e0d
changed pr name to Do not send empty emails for empty messages on 2026-10-21T15:32:32Z · by 9e834e0d
cmds
checkout latest patchset: 
ssh pr.pico.sh pull cheogram-smtp:ignore-empty | git am -3
checkout specific patchset revision: 
ssh pr.pico.sh pull cheogram-smtp:ignore-empty [rev] | git am -3
add changes to patch request: 
git format-patch main --stdout | ssh pr.pico.sh cheogram-smtp:ignore-empty
add comment to patch request: 
ssh pr.pico.sh comment cheogram-smtp:ignore-empty "lgtm!"

Patchset cheogram-smtp/ignore-empty.1 on 2026-10-21T15:32:06Z · commit 90e4db5

Update version bounds for newer ghc
Stephen Paul Weber 2026-10-21T14:19:52Z
 hlint clean
Stephen Paul Weber 2026-10-21T14:43:14Z
 make test
Stephen Paul Weber 2026-10-21T14:43:29Z
 This never fails
Stephen Paul Weber 2026-10-21T14:43:41Z
 → Do not send empty emails for empty messages
Stephen Paul Weber 2026-10-21T15:05:03Z
Do not send empty emails for empty messages
Stephen Paul Weber 2026-10-21T15:05:03Z
Especially chat state notifications etc
Semantic diff summary
0 added, 0 modified, 0 signature changed, 0 removed across 0 analyzed files (3 files skipped: unsupported file type)
+20 -12 Email.hs #
......@@ -597,13 +597,13 @@ messageToMIME ::
597597 (MIME.Boundary, MIME.Boundary)
598598 -> [Attachment]
599599 -> XMPP.Message
600- -> MIME.MIMEMessage
600+ -> Maybe MIME.MIMEMessage
601601 messageToMIME
602602 (b1, b2)
603603 attachments
604604 message@XMPP.Message { XMPP.messagePayloads = payload }
605605 | [xdc] <- XML.isNamed (s"{urn:xmpp:webxdc:0}x") =<< payload =
606- MIME.createMultipartMixedMessage b1 (NonEmpty.fromList [
606+ Just $ MIME.createMultipartMixedMessage b1 (NonEmpty.fromList [
607607 createMultipartMessage b2
608608 (MIME.Report $ s"status-update")
609609 (NonEmpty.fromList [
......@@ -616,19 +616,25 @@ messageToMIME
616616 ])
617617 | Just bodyTxt <- getBody message,
618618 null attachments =
619- MIME.createTextPlainMessage bodyTxt
620- | otherwise =
621- MIME.createMultipartMixedMessage b1 $ NonEmpty.fromList $
619+ Just $ MIME.createTextPlainMessage bodyTxt
620+ | isJust (getBody message) || not (null attachments) =
621+ Just $ MIME.createMultipartMixedMessage b1 $ NonEmpty.fromList $
622622 justZ (MIME.createTextPlainMessage <$> getBody message) ++
623623 map (\(Attachment mime name bytes) ->
624624 MIME.createAttachment
625625 mime (Just $ textToString name) bytes
626626 ) attachments
627+ | otherwise = Nothing
628+
629+data MessageToEmail =
630+ IgnoreMessage |
631+ MessageToEmailError XMPP.Message |
632+ SendEmail EmailWithEnvelope
627633
628634 messageToEmailIO :: (UIO.Unexceptional m) =>
629635 MIME.Domain
630636 -> XMPP.Message
631- -> m (Either XMPP.Message EmailWithEnvelope)
637+ -> m MessageToEmail
632638 messageToEmailIO domain message = do
633639 boundaries <- fromIO_ $ Random.getStdRandom Random.uniform
634640 attachments <- messageToAttachments message
......@@ -645,13 +651,15 @@ messageToEmail ::
645651 -> UTCTime
646652 -> Bool
647653 -> XMPP.Message
648- -> MIME.MIMEMessage
649- -> Either XMPP.Message EmailWithEnvelope
654+ -> Maybe MIME.MIMEMessage
655+ -> MessageToEmail
656+messageToEmail _ _ _ _ Nothing = IgnoreMessage
650657 messageToEmail fromDomain now threadHead message@XMPP.Message {
651658 XMPP.messageFrom = Just from,
652659 XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
653- } mime | Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode =
654- Right $ EmailWithEnvelope {
660+ } (Just mime)
661+ | Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode =
662+ SendEmail $ EmailWithEnvelope {
655663 emailEnvelopeFrom = fromAddrSpec,
656664 emailEnvelopeTo = toAddrSpec,
657665 emailMessage =
......@@ -667,7 +675,7 @@ messageToEmail fromDomain now threadHead message@XMPP.Message {
667675 set MIME.headerDate (Just dateHeader)
668676 mime
669677 }
670- | Left err <- parsedToNode = Left $
678+ | Left err <- parsedToNode = MessageToEmailError $
671679 messageError (
672680 errorPayload "cancel" "item-not-found"
673681 (fromString $ "Not a valid email address: " ++ err) []
......@@ -697,7 +705,7 @@ messageToEmail fromDomain now threadHead message@XMPP.Message {
697705 parsedToNode =
698706 MIME.parse (MIME.mailbox MIME.defaultCharsets) unescapedToNode
699707 unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
700-messageToEmail _ _ _ message _ = Left $
708+messageToEmail _ _ _ message _ = MessageToEmailError $
701709 messageError
702710 (errorPayload "modify" "bad-request" (s"Could not process message") [])
703711 message
+17 -13 gateway.hs #
......@@ -6,8 +6,8 @@ import System.IO
66 (stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
77 import Control.Concurrent (threadDelay)
88 import Control.Concurrent.STM (STM)
9-import Control.Error (exceptT, ExceptT(..), headZ, throwE)
10-import Control.Lens (over, set, at, _Right, traverseOf)
9+import Control.Error (exceptT, headZ)
10+import Control.Lens (over, set, at, traverseOf)
1111 import qualified Focus
1212 import qualified StmContainers.Map as STMMap
1313 import qualified Data.UUID as UUID
......@@ -121,17 +121,21 @@ messageHandler fromDomain sendmail sendIQ message@XMPP.Message {
121121 XMPP.messageFrom = from,
122122 XMPP.messageTo = to
123123 } = do
124- exceptT XMPP.putStanza return $ do
125- emailEither <- messageToEmailIO fromDomain message
126- email <- ExceptT $ traverseOf (_Right . emailMessage')
127- (\msg ->
128- maybe (return msg)
129- (fetchAndAddVCardData sendIQ msg to)
130- from
131- )
132- emailEither
133- result <- sendEmail sendmail email
134- if result then return () else throwE $ messageError err message
124+ messageResult <- messageToEmailIO fromDomain message
125+ case messageResult of
126+ IgnoreMessage -> return ()
127+ MessageToEmailError stanza -> XMPP.putStanza stanza
128+ SendEmail email -> do
129+ email' <- traverseOf emailMessage'
130+ (\msg ->
131+ maybe (return msg)
132+ (fetchAndAddVCardData sendIQ msg to)
133+ from
134+ )
135+ email
136+ result <- sendEmail sendmail email'
137+ unless result $
138+ XMPP.putStanza $ messageError err message
135139 where
136140 err = errorPayload "cancel" "undefined-condition"
137141 (s"Could not send email (maybe matched SPAM filter?)") []
+28 -2 test/EmailTest.hs #
......@@ -69,8 +69,19 @@ messageToEmailTest ::
6969 -> XMPP.Message
7070 -> Either XMPP.Message EmailWithEnvelope
7171 messageToEmailTest d now as m =
72- messageToEmail d now xdc m =<<
73- pure (messageToMIME (boundary1, boundary2) as m)
72+ case messageToEmailTestResult d now as m of
73+ MessageToEmailError err -> Left err
74+ SendEmail email -> Right email
75+ IgnoreMessage -> Left m
76+
77+messageToEmailTestResult ::
78+ MIME.Domain
79+ -> UTCTime
80+ -> [Attachment]
81+ -> XMPP.Message
82+ -> MessageToEmail
83+messageToEmailTestResult d now as m =
84+ messageToEmail d now xdc m (messageToMIME (boundary1, boundary2) as m)
7485 where
7586 xdc = any (matchWebXDC . mimeType) as
7687
......@@ -734,6 +745,21 @@ unit_messageToEmailChat =
734745 ]
735746 }
736747
748+unit_messageToEmailEmpty :: IO ()
749+unit_messageToEmailEmpty =
750+ case messageToEmailTestResult
751+ (MIME.DomainLiteral $ s"gateway.example.com")
752+ date [] message of
753+ IgnoreMessage -> pure ()
754+ _ -> assertFailure "empty XMPP messages should be ignored"
755+ where
756+ Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
757+ message = (XMPP.emptyMessage XMPP.MessageChat) {
758+ XMPP.messageTo =
759+ XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
760+ XMPP.messageFrom = XMPP.parseJID $ s"f@example.com"
761+ }
762+
737763 unit_messageToEmailWithSubject :: IO ()
738764 unit_messageToEmailWithSubject =
739765 hush (fmap (MIME.renderMessage . emailMessage) (
Back to top