Saku Laesvuori
b9941268b7
Yksi ainoa lähetysvirhe riitti aiemmin kaatamaan tiedotejärjestelmän postitussilmukan. Tällä muutoksella lähetysvirheet tulostetaan virhelokiin ja ne aiheuttaneet viestit unohdetaan.
105 lines
5.1 KiB
Haskell
105 lines
5.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module TiedoteMD.Send where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
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.IO (hClose, stdout, stderr)
|
|
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 qualified Data.Text.IO as T
|
|
|
|
import TiedoteMD.State
|
|
import TiedoteMD.Types
|
|
|
|
sendmail :: FilePath -> LBS.ByteString -> IO ()
|
|
sendmail path bs = do
|
|
(Just stdin, _, Just stderr, processHandle) <- createProcess
|
|
(proc path ["-t"]) {std_in = CreatePipe, std_err = CreatePipe}
|
|
LBS.hPut stdin bs
|
|
hClose stdin
|
|
errors <- T.hGetContents stderr
|
|
exitCode <- waitForProcess processHandle
|
|
-- TODO: handle System.Exit.Codes.codeTempFail differently from other failures
|
|
unless (exitCode == ExitSuccess) $ do
|
|
T.hPutStr System.IO.stderr $
|
|
"Sending mail with " <> (T.pack path) <> " failed with " <> (T.pack $ show exitCode)
|
|
unless (T.null errors) $ T.hPutStrLn System.IO.stderr $ ":\n" <> errors
|
|
T.hPutStrLn System.IO.stderr ""
|
|
|
|
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
|