From 778040bf9f3f60ec50b1b437f93ab123854917f2 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 26 Mar 2017 21:11:02 +0200 Subject: Copy mime-mail locally The path is wrong, it is configurable with --ghc-options but I can't get it right for now with stack. --- src/server/MimeMail.hs | 672 +++++++++++++++++++++++++++++++++++++++++++++++++ src/server/SendMail.hs | 19 +- 2 files changed, 681 insertions(+), 10 deletions(-) create mode 100644 src/server/MimeMail.hs (limited to 'src') diff --git a/src/server/MimeMail.hs b/src/server/MimeMail.hs new file mode 100644 index 0000000..0faaf98 --- /dev/null +++ b/src/server/MimeMail.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MimeMail + ( -- * Datatypes + Boundary (..) + , Mail (..) + , emptyMail + , Address (..) + , Alternatives + , Part (..) + , Encoding (..) + , Headers + -- * Render a message + , renderMail + , renderMail' + -- * Sending messages + , sendmail + , sendmailCustom + , sendmailCustomCaptureOutput + , renderSendMail + , renderSendMailCustom + -- * High-level 'Mail' creation + , simpleMail + , simpleMail' + , simpleMailInMemory + -- * Utilities + , addPart + , addAttachment + , addAttachmentCid + , addAttachments + , addAttachmentBS + , addAttachmentBSCid + , addAttachmentsBS + , renderAddress + , htmlPart + , plainPart + , randomString + , quotedPrintable + ) where + +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder.Char.Utf8 +import Blaze.ByteString.Builder +import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) +import Data.Monoid +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import System.FilePath (takeFileName) +import qualified Data.ByteString.Base64 as Base64 +import Control.Monad ((<=<), foldM, void) +import Control.Exception (throwIO, ErrorCall (ErrorCall)) +import Data.List (intersperse) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.ByteString.Char8 () +import Data.Bits ((.&.), shiftR) +import Data.Char (isAscii, isControl) +import Data.Word (Word8) +import qualified Data.ByteString as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | Generates a random sequence of alphanumerics of the given length. +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | MIME boundary between parts of a message. +newtype Boundary = Boundary { unBoundary :: Text } + deriving (Eq, Show) +instance Random Boundary where + randomR = const random + random = first (Boundary . T.pack) . randomString 10 + +-- | An entire mail message. +data Mail = Mail + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] + -- | Other headers, excluding from, to, cc and bcc. + , mailHeaders :: Headers + -- | A list of different sets of alternatives. As a concrete example: + -- + -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] + -- + -- Make sure when specifying alternatives to place the most preferred + -- version last. + , mailParts :: [Alternatives] + } + deriving Show + +-- | A mail message with the provided 'from' address and no other +-- fields filled in. +emptyMail :: Address -> Mail +emptyMail from = Mail + { mailFrom = from + , mailTo = [] + , mailCc = [] + , mailBcc = [] + , mailHeaders = [] + , mailParts = [] + } + +data Address = Address + { addressName :: Maybe Text + , addressEmail :: Text + } + deriving (Eq, Show) + +-- | How to encode a single part. You should use 'Base64' for binary data. +data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary + deriving (Eq, Show) + +-- | Multiple alternative representations of the same data. For example, you +-- could provide a plain-text and HTML version of a message. +type Alternatives = [Part] + +-- | A single part of a multipart message. +data Part = Part + { partType :: Text -- ^ content type + , partEncoding :: Encoding + -- | The filename for this part, if it is to be sent with an attachemnt + -- disposition. + , partFilename :: Maybe Text + , partHeaders :: Headers + , partContent :: L.ByteString + } + deriving (Eq, Show) + +type Headers = [(S.ByteString, Text)] +type Pair = (Headers, Builder) + +partToPair :: Part -> Pair +partToPair (Part contentType encoding disposition headers content) = + (headers', builder) + where + headers' = + ((:) ("Content-Type", contentType)) + $ (case encoding of + None -> id + Base64 -> (:) ("Content-Transfer-Encoding", "base64") + QuotedPrintableText -> + (:) ("Content-Transfer-Encoding", "quoted-printable") + QuotedPrintableBinary -> + (:) ("Content-Transfer-Encoding", "quoted-printable")) + $ (case disposition of + Nothing -> id + Just fn -> + (:) ("Content-Disposition", "attachment; filename=" + `T.append` fn)) + $ headers + builder = + case encoding of + None -> fromWriteList writeByteString $ L.toChunks content + Base64 -> base64 content + QuotedPrintableText -> quotedPrintable True content + QuotedPrintableBinary -> quotedPrintable False content + +showPairs :: RandomGen g + => Text -- ^ multipart type, eg mixed, alternative + -> [Pair] + -> g + -> (Pair, g) +showPairs _ [] _ = error "renderParts called with null parts" +showPairs _ [pair] gen = (pair, gen) +showPairs mtype parts gen = + ((headers, builder), gen') + where + (Boundary b, gen') = random gen + headers = + [ ("Content-Type", T.concat + [ "multipart/" + , mtype + , "; boundary=\"" + , b + , "\"" + ]) + ] + builder = mconcat + [ mconcat $ intersperse (fromByteString "\n") + $ map (showBoundPart $ Boundary b) parts + , showBoundEnd $ Boundary b + ] + +-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. +renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) +renderMail g0 (Mail from to cc bcc headers parts) = + (toLazyByteString builder, g'') + where + addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] + pairs = map (map partToPair) parts + (pairs', g') = helper g0 $ map (showPairs "alternative") pairs + helper :: g -> [g -> (x, g)] -> ([x], g) + helper g [] = ([], g) + helper g (x:xs) = + let (b, g_) = x g + (bs, g__) = helper g_ xs + in (b : bs, g__) + ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' + builder = mconcat + [ mconcat addressHeaders + , mconcat $ map showHeader headers + , showHeader ("MIME-Version", "1.0") + , mconcat $ map showHeader finalHeaders + , fromByteString "\n" + , finalBuilder + ] + +-- | Format an E-Mail address according to the name-addr form (see: RFC5322 +-- ยง 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') +-- This can be handy for adding custom headers that require such format. +-- +-- @since 0.4.11 +renderAddress :: Address -> Text +renderAddress address = + TE.decodeUtf8 $ toByteString $ showAddress address + +-- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) +sanitizeFieldName :: S.ByteString -> S.ByteString +sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) + +showHeader :: (S.ByteString, Text) -> Builder +showHeader (k, v) = mconcat + [ fromByteString (sanitizeFieldName k) + , fromByteString ": " + , encodeIfNeeded (sanitizeHeader v) + , fromByteString "\n" + ] + +showAddressHeader :: (S.ByteString, [Address]) -> Builder +showAddressHeader (k, as) = + if null as + then mempty + else mconcat + [ fromByteString k + , fromByteString ": " + , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) + , fromByteString "\n" + ] + +-- | +-- +-- Since 0.4.3 +showAddress :: Address -> Builder +showAddress a = mconcat + [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) + , fromByteString "<" + , fromText (sanitizeHeader $ addressEmail a) + , fromByteString ">" + ] + +-- Filter out control characters to prevent CRLF injection. +sanitizeHeader :: Text -> Text +sanitizeHeader = T.filter (not . isControl) + +showBoundPart :: Boundary -> (Headers, Builder) -> Builder +showBoundPart (Boundary b) (headers, content) = mconcat + [ fromByteString "--" + , fromText b + , fromByteString "\n" + , mconcat $ map showHeader headers + , fromByteString "\n" + , content + ] + +showBoundEnd :: Boundary -> Builder +showBoundEnd (Boundary b) = mconcat + [ fromByteString "\n--" + , fromText b + , fromByteString "--" + ] + +-- | Like 'renderMail', but generates a random boundary. +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + g <- getStdGen + let (lbs, g') = renderMail g m + setStdGen g' + return lbs + +-- | Send a fully-formed email message via the default sendmail +-- executable with default options. +sendmail :: L.ByteString -> IO () +sendmail = sendmailCustom sendmailPath ["-t"] + +sendmailPath :: String +sendmailPath = "sendmail" + +-- | Render an email message and send via the default sendmail +-- executable with default options. +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' + +-- | Send a fully-formed email message via the specified sendmail +-- executable with specified options. +sendmailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> L.ByteString -- ^ mail message as lazy bytestring + -> IO () +sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs + +-- | Like 'sendmailCustom', but also returns sendmail's output to stderr and +-- stdout as strict ByteStrings. +-- +-- Since 0.4.9 +sendmailCustomCaptureOutput :: FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs + +sendmailCustomAux :: Bool + -> FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomAux captureOut sm opts lbs = do + let baseOpts = (proc sm opts) { std_in = CreatePipe } + pOpts = if captureOut + then baseOpts { std_out = CreatePipe + , std_err = CreatePipe + } + else baseOpts + (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts + L.hPut hin lbs + hClose hin + errMVar <- newEmptyMVar + outMVar <- newEmptyMVar + case (mHOut, mHErr) of + (Nothing, Nothing) -> return () + (Just hOut, Just hErr) -> do + void . forkIO $ S.hGetContents hOut >>= putMVar outMVar + void . forkIO $ S.hGetContents hErr >>= putMVar errMVar + _ -> error "error in sendmailCustomAux: missing a handle" + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> if captureOut + then do + errOutput <- takeMVar errMVar + outOutput <- takeMVar outMVar + return (outOutput, errOutput) + else return (S.empty, S.empty) + _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) + +-- | Render an email message and send via the specified sendmail +-- executable with specified options. +renderSendMailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> Mail -- ^ mail to render and send + -> IO () +renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' + +-- FIXME usage of FilePath below can lead to issues with filename encoding + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some file attachments. +-- +-- Note that we use lazy IO for reading in the attachment contents. +simpleMail :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, FilePath)] -- ^ content type and path of attachments + -> IO Mail +simpleMail to from subject plainBody htmlBody attachments = + addAttachments attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with only plain-text body. +simpleMail' :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ body + -> Mail +simpleMail' to from subject body = addPart [plainPart body] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some 'ByteString' attachments. +-- +-- Since 0.4.7 +simpleMailInMemory :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments + -> Mail +simpleMailInMemory to from subject plainBody htmlBody attachments = + addAttachmentsBS attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +mailFromToSubject :: Address -- ^ from + -> Address -- ^ to + -> Text -- ^ subject + -> Mail +mailFromToSubject from to subject = + (emptyMail from) { mailTo = [to] + , mailHeaders = [("Subject", subject)] + } + +-- | Add an 'Alternative' to the 'Mail's parts. +-- +-- To e.g. add a plain text body use +-- > addPart [plainPart body] (emptyMail from) +addPart :: Alternatives -> Mail -> Mail +addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } + +-- | Construct a UTF-8-encoded plain-text 'Part'. +plainPart :: LT.Text -> Part +plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/plain; charset=utf-8" + +-- | Construct a UTF-8-encoded html 'Part'. +htmlPart :: LT.Text -> Part +htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/html; charset=utf-8" + +-- | Add an attachment from a file and construct a 'Part'. +addAttachment :: Text -> FilePath -> Mail -> IO Mail +addAttachment ct fn mail = do + part <- getAttachmentPart ct fn + return $ addPart [part] mail + +-- | Add an attachment from a file and construct a 'Part' +-- with the specified content id in the Content-ID header. +-- +-- @since 0.4.12 +addAttachmentCid :: Text -- ^ content type + -> FilePath -- ^ file name + -> Text -- ^ content ID + -> Mail + -> IO Mail +addAttachmentCid ct fn cid mail = + getAttachmentPart ct fn >>= (return.addToMail.addHeader) + where + addToMail part = addPart [part] mail + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail +addAttachments xs mail = foldM fun mail xs + where fun m (c, f) = addAttachment c f m + +-- | Add an attachment from a 'ByteString' and construct a 'Part'. +-- +-- Since 0.4.7 +addAttachmentBS :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Mail -> Mail +addAttachmentBS ct fn content mail = + let part = getAttachmentPartBS ct fn content + in addPart [part] mail + +-- | @since 0.4.12 +addAttachmentBSCid :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Text -- ^ content ID + -> Mail -> Mail +addAttachmentBSCid ct fn content cid mail = + let part = addHeader $ getAttachmentPartBS ct fn content + in addPart [part] mail + where + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +-- | +-- Since 0.4.7 +addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail +addAttachmentsBS xs mail = foldl fun mail xs + where fun m (ct, fn, content) = addAttachmentBS ct fn content m + +getAttachmentPartBS :: Text + -> Text + -> L.ByteString + -> Part +getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content + +getAttachmentPart :: Text -> FilePath -> IO Part +getAttachmentPart ct fn = do + content <- L.readFile fn + return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content + +data QP = QPPlain S.ByteString + | QPNewline + | QPTab + | QPSpace + | QPEscape S.ByteString + +data QPC = QPCCR + | QPCLF + | QPCSpace + | QPCTab + | QPCPlain + | QPCEscape + deriving Eq + +toQP :: Bool -- ^ text? + -> L.ByteString + -> [QP] +toQP isText = + go + where + go lbs = + case L.uncons lbs of + Nothing -> [] + Just (c, rest) -> + case toQPC c of + QPCCR -> go rest + QPCLF -> QPNewline : go rest + QPCSpace -> QPSpace : go rest + QPCTab -> QPTab : go rest + QPCPlain -> + let (x, y) = L.span ((== QPCPlain) . toQPC) lbs + in QPPlain (toStrict x) : go y + QPCEscape -> + let (x, y) = L.span ((== QPCEscape) . toQPC) lbs + in QPEscape (toStrict x) : go y + + toStrict = S.concat . L.toChunks + + toQPC :: Word8 -> QPC + toQPC 13 | isText = QPCCR + toQPC 10 | isText = QPCLF + toQPC 9 = QPCTab + toQPC 0x20 = QPCSpace + toQPC 46 = QPCEscape + toQPC 61 = QPCEscape + toQPC w + | 33 <= w && w <= 126 = QPCPlain + | otherwise = QPCEscape + +buildQPs :: [QP] -> Builder +buildQPs = + go (0 :: Int) + where + go _ [] = mempty + go currLine (qp:qps) = + case qp of + QPNewline -> copyByteString "\r\n" `mappend` go 0 qps + QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) + QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) + QPPlain bs -> + let toTake = 75 - currLine + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPPlain y : qps + in helper (S.length x) (copyByteString x) (S.null y) rest + QPEscape bs -> + let toTake = (75 - currLine) `div` 3 + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPEscape y : qps + in if toTake == 0 + then copyByteString "=\r\n" `mappend` go 0 (qp:qps) + else helper (S.length x * 3) (escape x) (S.null y) rest + where + escape = + S.foldl' add mempty + where + add builder w = + builder `mappend` escaped + where + escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + + helper added builder noMore rest = + builder' `mappend` go newLine rest + where + (newLine, builder') + | not noMore || (added + currLine) >= 75 = + (0, builder `mappend` copyByteString "=\r\n") + | otherwise = (added + currLine, builder) + + wsHelper enc raw + | null qps = + if currLine <= 73 + then enc + else copyByteString "\r\n=" `mappend` enc + | otherwise = helper 1 raw (currLine < 76) qps + +-- | The first parameter denotes whether the input should be treated as text. +-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If +-- binary, then CRs and LFs will be escaped. +quotedPrintable :: Bool -> L.ByteString -> Builder +quotedPrintable isText = buildQPs . toQP isText + +hex :: Word8 -> Builder +hex x + | x < 10 = fromWord8 $ x + 48 + | otherwise = fromWord8 $ x + 55 + +encodeIfNeeded :: Text -> Builder +encodeIfNeeded t = + if needsEncodedWord t + then encodedWord t + else fromText t + +needsEncodedWord :: Text -> Bool +needsEncodedWord = not . T.all isAscii + +encodedWord :: Text -> Builder +encodedWord t = mconcat + [ fromByteString "=?utf-8?Q?" + , S.foldl' go mempty $ TE.encodeUtf8 t + , fromByteString "?=" + ] + where + go front w = front `mappend` go' w + go' 32 = fromWord8 95 -- space + go' 95 = go'' 95 -- _ + go' 63 = go'' 63 -- ? + go' 61 = go'' 61 -- = + + -- The special characters from RFC 2822. Not all of these always give + -- problems, but at least @[];"<>, gave problems with some mail servers + -- when used in the 'name' part of an address. + go' 34 = go'' 34 -- " + go' 40 = go'' 40 -- ( + go' 41 = go'' 41 -- ) + go' 44 = go'' 44 -- , + go' 46 = go'' 46 -- . + go' 58 = go'' 58 -- ; + go' 59 = go'' 59 -- ; + go' 60 = go'' 60 -- < + go' 62 = go'' 62 -- > + go' 64 = go'' 64 -- @ + go' 91 = go'' 91 -- [ + go' 92 = go'' 92 -- \ + go' 93 = go'' 93 -- ] + go' w + | 33 <= w && w <= 126 = fromWord8 w + | otherwise = go'' w + go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + +-- 57 bytes, when base64-encoded, becomes 76 characters. +-- Perform the encoding 57-bytes at a time, and then append a newline. +base64 :: L.ByteString -> Builder +base64 lbs + | L.null lbs = mempty + | otherwise = fromByteString x64 `mappend` + fromByteString "\r\n" `mappend` + base64 y + where + (x', y) = L.splitAt 57 lbs + x = S.concat $ L.toChunks x' + x64 = Base64.encode x diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs index e434b38..f7ba3fd 100644 --- a/src/server/SendMail.hs +++ b/src/server/SendMail.hs @@ -4,25 +4,24 @@ module SendMail ( sendMail ) where +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) + import Data.Text (Text) +import Data.Text.Lazy.Builder (toLazyText, fromText) import qualified Data.Text as T -import Data.Either (isLeft) import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder (toLazyText, fromText) - -import Control.Exception (SomeException, try) -import Control.Arrow (left) - -import qualified Network.Mail.Mime as M +import qualified MimeMail as M -import Model.Mail +import Model.Mail (Mail(Mail)) sendMail :: Mail -> IO (Either Text ()) sendMail mail = do result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail)) - else return () + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else putStrLn "OK" return result getMimeMail :: Mail -> M.Mail -- cgit v1.2.3