Saku Laesvuori
eddbceba67
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.
100 lines
4.8 KiB
Haskell
100 lines
4.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module TiedoteMD.Send where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Exception (throwIO)
|
|
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(..), 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)
|
|
import System.IO (hClose, stdout)
|
|
import System.Process (CreateProcess(..), StdStream(..), waitForProcess, createProcess, proc)
|
|
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
|
|
import TiedoteMD.Types
|
|
|
|
sendmail :: FilePath -> LBS.ByteString -> IO ()
|
|
sendmail path bs = do
|
|
(Just stdin, _, _, processHandle) <- createProcess (proc path ["-t"]) {std_in = CreatePipe}
|
|
LBS.hPut stdin bs
|
|
hClose stdin
|
|
exitCode <- waitForProcess processHandle
|
|
unless (exitCode `elem` [ExitSuccess, codeTempFail]) $
|
|
throwIO $ ProcessError (T.pack path) exitCode
|
|
|
|
manageQueue :: AcidState State -> Mailbox -> FilePath -> IO ()
|
|
manageQueue acid sender sendmailPath = forever $ do
|
|
maybeNextJob <- query acid GetMessageFromQueue
|
|
case maybeNextJob of
|
|
Nothing -> pure ()
|
|
Just (address, message) -> do
|
|
boundary <- getStdRandom uniform
|
|
boundary' <- getStdRandom uniform
|
|
let mail = renderMessage message sender boundary boundary'
|
|
sendmail sendmailPath $ toLazyByteString $ buildMessage $
|
|
set (headerTo defaultCharsets) [Single $ emailToMailbox address] mail
|
|
update acid MarkMessageAsSent
|
|
-- Delay for 3s to reduce spamminess
|
|
threadDelay $ 3 * 1000 * 1000
|
|
|
|
manageQueueingMessages :: AcidState State -> IO ()
|
|
manageQueueingMessages acid = forever $ do
|
|
-- TODO: sleep until next move or updateMessages to save CPU and acid storage size
|
|
threadDelay $ 10 * 1000 * 1000
|
|
queueMessages acid
|
|
|
|
queueMessages :: AcidState State -> IO ()
|
|
queueMessages acid = getCurrentTime >>= update acid . MoveToSendQueue
|
|
|
|
renderMessage :: Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage
|
|
renderMessage = renderMessage' "" Nothing
|
|
|
|
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" $
|
|
-- Apparently some big mail providers want mass email to include "Precedence: Bulk"
|
|
set (headerFrom defaultCharsets) [Single sender] $
|
|
IMF.Message (Headers []) $ Multipart Alternative boundary $ NE.fromList
|
|
[ createTextPlainMessage plainTextMessage
|
|
, createTextMarkdownMessage markdownMessage
|
|
, createTextHtmlMessage boundary' mediaParts htmlMessage
|
|
]
|
|
|
|
createTextMarkdownMessage :: T.Text -> MIMEMessage
|
|
createTextMarkdownMessage = set contentType "text/markdown; charset=utf-8; variant=pandoc" . createTextPlainMessage
|
|
|
|
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
|