From eddbceba6742aca35271b7ee966aa6a44d1cb87b Mon Sep 17 00:00:00 2001 From: Saku Laesvuori Date: Wed, 17 Apr 2024 13:33:02 +0300 Subject: [PATCH] =?UTF-8?q?Liit=C3=A4=20mediatiedostot=20viesteihin?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit HTML-sähköpostit voivat linkata liitteisiin, jolloin viesti on itsenäinen. Viestin sisäisiin kuviin linkkaaminen toimii yleensä sähköpostiohjelmissa ulkoisia linkkejä paremmin, koska ulkoisten linkkien seuraaminen on yksityisyysriski. --- .guix/modules/tiedote-md-package.scm | 2 ++ src/TiedoteMD/Read.hs | 43 ++++++++++++++++++++++++++-- src/TiedoteMD/Review.hs | 3 +- src/TiedoteMD/Send.hs | 37 +++++++++++++++++------- src/TiedoteMD/Types.hs | 32 +++++++++++++++++++-- tiedote-md.cabal | 4 +++ 6 files changed, 105 insertions(+), 16 deletions(-) diff --git a/.guix/modules/tiedote-md-package.scm b/.guix/modules/tiedote-md-package.scm index e6c5c50..c12f9f8 100644 --- a/.guix/modules/tiedote-md-package.scm +++ b/.guix/modules/tiedote-md-package.scm @@ -26,6 +26,8 @@ #:select? vcs-file?)) (build-system haskell-build-system) (inputs (list ghc-acid-state + ghc-attoparsec + ghc-base64 ghc-cryptonite ghc-case-insensitive ghc-glob diff --git a/src/TiedoteMD/Read.hs b/src/TiedoteMD/Read.hs index 2d8a0c9..4e5bd4b 100644 --- a/src/TiedoteMD/Read.hs +++ b/src/TiedoteMD/Read.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} module TiedoteMD.Read where @@ -16,10 +17,13 @@ import Data.Acid (AcidState, update) import Data.Bifunctor (first, second) import Data.ByteArray (convert) import Data.ByteString (ByteString) +import "base64" Data.ByteString.Base64.URL import Data.Default (def) -import Data.Either (rights, lefts) +import Data.Either (rights, lefts, fromRight) import Data.FileStore (FileStore(..), Revision(..), FileStoreError(..), gitFileStore) import Data.List (singleton, isSuffixOf) +import Data.MIME (ContentID, makeContentID, renderContentID) +import Data.Maybe (fromMaybe) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time (UTCTime, zonedTimeToUTC) import Data.Time (getCurrentTime) @@ -29,12 +33,15 @@ import System.FilePath.Glob (match, compile) import System.IO (hClose) import System.Process (createProcess, proc, waitForProcess, CreateProcess(..), StdStream(..)) import Text.Pandoc (Pandoc(..), PandocMonad, PandocIO, PandocError) +import Text.Pandoc.MediaBag (MediaItem(..), lookupMedia, mediaItems) import Text.Pandoc.Readers (readMarkdown) +import Text.Pandoc.Walk (walkM) import Text.Pandoc.Writers (writePlain, writeMarkdown, writeHtml5String) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Text.Pandoc as Pandoc @@ -101,10 +108,40 @@ readMessageFile store = flip (retrieve store) Nothing >=> uncurry (parseMessageFile store) . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text) +cidOf :: MediaItem -> ContentID +cidOf MediaItem {mediaContents, mediaMimeType} = + fromRight (error "makeContentID failed with valid input!") $ + makeContentID $ "<" <> encodedHash <> "@tiedote.md.sha256>" + where encodedHash = encodeBase64' $ convert $ hashWith SHA256 $ + LBS.toStrict mediaContents <> encodeUtf8 mediaMimeType + +cidUrl :: ContentID -> T.Text +cidUrl = mappend "cid:" . stripAngleBrackets . decodeUtf8 . renderContentID + where stripAngleBrackets = T.init . T.tail + -- The string is always surrounded by < > so this is safe + +makeMediaPart :: MediaItem -> MediaPart +makeMediaPart mediaItem@MediaItem {..} = MediaPart + { mediaPartMimeType = encodeUtf8 mediaMimeType + , mediaPartContentID = renderContentID $ cidOf mediaItem + , mediaPartContents = LBS.toStrict mediaContents + } + +reconstructMediaItem :: (FilePath, T.Text, LBS.ByteString) -> MediaItem +reconstructMediaItem (mediaPath, mediaMimeType, mediaContents) = MediaItem {..} + +replaceImagesWithCid :: PandocMonad m => Pandoc -> m Pandoc +replaceImagesWithCid = Pandoc.fillMediaBag >=> walkM handleImage + where handleImage (Pandoc.Image attr lab (src, title)) = do + mediaItem <- (\media -> fromMaybe (error $ "fillMediaBag left an image uncollected! impossible!") + $ lookupMedia (T.unpack src) media) <$> Pandoc.getMediaBag + pure $ Pandoc.Image attr lab (cidUrl $ cidOf mediaItem, title) + handleImage x = pure x + parseMessageFile :: FileStore -> ByteString -> T.Text -> IO (Either Error Message) parseMessageFile store hash text = fmap (join . first PandocError) . runReadM store $ do pandoc@(Pandoc meta _) <- flip readMarkdown text - def {Pandoc.readerStandalone = True, Pandoc.readerExtensions = Pandoc.pandocExtensions} + def {Pandoc.readerStandalone = True, Pandoc.readerExtensions = Pandoc.pandocExtensions} >>= replaceImagesWithCid let tiedoteMeta = do previewTo <- lookupMeta' "tarkistaja" meta >>= metaToEmails previewTime <- lookupMeta' "deadline" meta >>= metaToTime @@ -120,6 +157,7 @@ parseMessageFile store hash text = fmap (join . first PandocError) . runReadM st (Pandoc.Meta $ Map.insertWith (flip const) "pagetitle" (Pandoc.MetaString subject) $ Pandoc.unMeta meta') blocks' htmlMessage <- liftIO . inlineCSS =<< renderHelper writeHtml5String htmlTemplate htmlPandoc + mediaParts <- Set.fromList . map (makeMediaPart . reconstructMediaItem) . mediaItems <$> Pandoc.getMediaBag pure $ pure $ Message { recipients = [] , messageHash = hash @@ -133,7 +171,6 @@ parseMessageFile store hash text = fmap (join . first PandocError) . runReadM st , Pandoc.writerTableOfContents = True , Pandoc.writerSectionDivs = True } - -- TODO: Store the media somewhere inlineCSS :: T.Text -> IO T.Text inlineCSS html = do diff --git a/src/TiedoteMD/Review.hs b/src/TiedoteMD/Review.hs index 1208591..c673a54 100644 --- a/src/TiedoteMD/Review.hs +++ b/src/TiedoteMD/Review.hs @@ -54,7 +54,8 @@ managePreviews acid sender sendmailPath = forever $ do Just msg@(Message {..}) -> do mailID <- uniqueMailID sender boundary <- getStdRandom uniform - let mail = renderMessage' "Esikatselu: " (Just mailID) msg sender boundary + boundary' <- getStdRandom uniform + let mail = renderMessage' "Esikatselu: " (Just mailID) msg sender boundary boundary' sendmail sendmailPath $ toLazyByteString $ buildMessage $ set (headerTo defaultCharsets) (map (Single . emailToMailbox) previewTo) mail update acid $ SetPreviewID messageHash mailID diff --git a/src/TiedoteMD/Send.hs b/src/TiedoteMD/Send.hs index 2a56a4a..0b9963d 100644 --- a/src/TiedoteMD/Send.hs +++ b/src/TiedoteMD/Send.hs @@ -5,12 +5,14 @@ module TiedoteMD.Send where import Control.Concurrent (threadDelay) import Control.Exception (throwIO) -import Control.Lens (set) +import Control.Lens (set, _Just) import Control.Monad (forever, unless) import Data.Acid (AcidState, query, update) +import Data.Attoparsec.ByteString (endOfInput, parseOnly) import Data.Binary.Builder (toLazyByteString) -import Data.MIME (Address(..), Mailbox, Boundary, MIMEMessage, MIME(..), Headers(..), MultipartSubtype(..), buildMessage, headerTo, headerSubject, headerFrom, headerMessageID, header, createTextPlainMessage, contentType) +import Data.MIME (Address(..), Mailbox, Boundary, MIMEMessage, MIME(..), Headers(..), MultipartSubtype(..), ContentTypeWith(..), DispositionType(..), buildMessage, headerTo, headerSubject, headerFrom, headerMessageID, headerContentID, header, createTextPlainMessage, contentType, contentDisposition, dispositionType, createAttachment, parseContentType, makeContentID) import Data.MIME.Charset (defaultCharsets) +import Data.Set (Set) import Data.Time (getCurrentTime) import System.Exit (ExitCode(..)) import System.Exit.Codes (codeTempFail) @@ -21,6 +23,7 @@ import System.Random (getStdRandom, uniform) import qualified Data.ByteString.Lazy as LBS import qualified Data.IMF as IMF import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set import qualified Data.Text as T import TiedoteMD.State @@ -42,7 +45,8 @@ manageQueue acid sender sendmailPath = forever $ do Nothing -> pure () Just (address, message) -> do boundary <- getStdRandom uniform - let mail = renderMessage message sender boundary + boundary' <- getStdRandom uniform + let mail = renderMessage message sender boundary boundary' sendmail sendmailPath $ toLazyByteString $ buildMessage $ set (headerTo defaultCharsets) [Single $ emailToMailbox address] mail update acid MarkMessageAsSent @@ -58,11 +62,11 @@ manageQueueingMessages acid = forever $ do queueMessages :: AcidState State -> IO () queueMessages acid = getCurrentTime >>= update acid . MoveToSendQueue -renderMessage :: Message -> Mailbox -> Boundary -> MIMEMessage +renderMessage :: Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage renderMessage = renderMessage' "" Nothing -renderMessage' :: T.Text -> Maybe MailID -> Message -> Mailbox -> Boundary -> MIMEMessage -renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageContent {..},..}) sender boundary = +renderMessage' :: T.Text -> Maybe MailID -> Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage +renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageContent {..},..}) sender boundary boundary' = maybe id (set headerMessageID . Just . mailIDToMessageID) maybeMailID $ set (headerSubject defaultCharsets) (Just $ subjectPrefix <> subject) $ set (header "Precedence") "Bulk" $ @@ -71,12 +75,25 @@ renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageConte IMF.Message (Headers []) $ Multipart Alternative boundary $ NE.fromList [ createTextPlainMessage plainTextMessage , createTextMarkdownMessage markdownMessage - , createTextHtmlMessage htmlMessage + , createTextHtmlMessage boundary' mediaParts htmlMessage ] createTextMarkdownMessage :: T.Text -> MIMEMessage createTextMarkdownMessage = set contentType "text/markdown; charset=utf-8; variant=pandoc" . createTextPlainMessage -createTextHtmlMessage :: T.Text -> MIMEMessage -createTextHtmlMessage = set contentType "text/html; charset=utf-8" . createTextPlainMessage --- TODO: multipart/related with media +createTextHtmlMessage :: Boundary -> Set MediaPart -> T.Text -> MIMEMessage +createTextHtmlMessage boundary mediaParts html = IMF.Message (Headers []) $ multipartRelated $ + (set contentType "text/html; charset=utf-8" $ createTextPlainMessage html) NE.:| mediaAttachments + where multipartRelated = Multipart + (Related (Just $ ContentType "text" "html" ()) Nothing Nothing) boundary + mediaAttachments = mediaPartToAttachment <$> Set.toList mediaParts + +mediaPartToAttachment :: MediaPart -> MIMEMessage +mediaPartToAttachment MediaPart {..} = + set (contentDisposition . _Just . dispositionType) Inline $ + set headerContentID (Just contentID) $ + createAttachment mimeType Nothing mediaPartContents + where mimeType = either (error "purebred-email couldn't parse pandoc's mime type!") id $ + parseOnly (parseContentType <* endOfInput) mediaPartMimeType + contentID = either (error "purebred-email couldn't parse it's own contentID!") id $ + makeContentID mediaPartContentID diff --git a/src/TiedoteMD/Types.hs b/src/TiedoteMD/Types.hs index 567ed98..5682dab 100644 --- a/src/TiedoteMD/Types.hs +++ b/src/TiedoteMD/Types.hs @@ -1,11 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeFamilies #-} module TiedoteMD.Types ( Email(..) , Error(..) , MailID + , MediaPart(..) , Message(..) , MessageContent(..) , SendJob(..) @@ -28,8 +31,9 @@ import Data.CaseInsensitive (original, mk) import Data.IMF (MessageID, Mailbox(..), AddrSpec(..), Domain(..), mailbox, parseMessageID, parse, renderMessageID, renderMailbox) import Data.List.NonEmpty (NonEmpty) import Data.MIME.Charset (defaultCharsets) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.Semigroup (sconcat) +import Data.Set (Set) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time (UTCTime, getCurrentTime, defaultTimeLocale, formatTime) @@ -88,6 +92,23 @@ data Message = Message } deriving (Show, Eq, Typeable) data MessageContent = MessageContent + { plainTextMessage :: Text + , markdownMessage :: Text + , htmlMessage :: Text + , mediaParts :: Set MediaPart + } deriving (Show, Eq, Typeable) + +data MediaPart = MediaPart + -- XXX Ideally purebred-email would implement safecopy and we could use proper types + { mediaPartMimeType :: ByteString -- ContentTypeWith Parameters + , mediaPartContentID :: ByteString -- ContentID + , mediaPartContents :: ByteString + } deriving (Show, Typeable, Ord) + +instance Eq MediaPart where + MediaPart {mediaPartContentID = a} == MediaPart {mediaPartContentID = b} = a == b + +data MessageContent_v0 = MessageContent_v0 { plainTextMessage :: Text , markdownMessage :: Text , htmlMessage :: Text @@ -148,7 +169,14 @@ renderError (FileNotFoundError path) = T.pack path <> " not found" deriveSafeCopy 0 'base ''Domain' deriveSafeCopy 0 'base ''Email -deriveSafeCopy 0 'base ''MessageContent +deriveSafeCopy 0 'base ''MessageContent_v0 +deriveSafeCopy 0 'base ''MediaPart + +instance Migrate MessageContent where + type MigrateFrom MessageContent = MessageContent_v0 + migrate MessageContent_v0 {..} = MessageContent {mediaParts = mempty, ..} + +deriveSafeCopy 1 'extension ''MessageContent deriveSafeCopy 0 'base ''MailID deriveSafeCopy 0 'base ''Message deriveSafeCopy 0 'base ''SendJob diff --git a/tiedote-md.cabal b/tiedote-md.cabal index cff816e..5ee4b7b 100644 --- a/tiedote-md.cabal +++ b/tiedote-md.cabal @@ -23,7 +23,9 @@ source-repository head executable tiedote.md build-depends: acid-state, + attoparsec, base, + base64, binary, bytestring, case-insensitive, @@ -35,6 +37,7 @@ executable tiedote.md doctemplates, exit-codes, file-embed, + filepath, filestore, Glob, hostname, @@ -44,6 +47,7 @@ executable tiedote.md network, optparse-applicative, pandoc, + pandoc-types, process, purebred-email, random,