Liitä mediatiedostot viesteihin

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

@@ -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

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

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

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' :: T.Text -> Maybe MailID -> Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage
-renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageContent {..},..}) sender boundary =
+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 :: Boundary -> Set MediaPart -> T.Text -> MIMEMessage
-createTextHtmlMessage = set contentType "text/html; charset=utf-8" . createTextPlainMessage
+createTextHtmlMessage boundary mediaParts html = IMF.Message (Headers []) $ multipartRelated $
--- TODO: multipart/related with media
+    (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

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

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,