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.
This commit is contained in:
parent
373e34a9e4
commit
eddbceba67
GPG Key ID:
257D284A2A1D3A32
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user