path: root/server/src/MimeMail.hs

{-# 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           Blaze.ByteString.Builder
import           Blaze.ByteString.Builder.Char.Utf8
import           Control.Arrow
import           Control.Concurrent                 (forkIO, newEmptyMVar,
                                                     putMVar, takeMVar)
import           Control.Exception                  (ErrorCall (ErrorCall),
                                                     throwIO)
import           Control.Monad                      (foldM, void, (<=<))
import           Data.Bits                          (shiftR, (.&.))
import qualified Data.ByteString                    as S
import qualified Data.ByteString.Base64             as Base64
import           Data.ByteString.Char8              ()
import qualified Data.ByteString.Lazy               as L
import           Data.Char                          (isAscii, isControl)
import           Data.List                          (intersperse)
import           Data.Monoid
import           Data.Text                          (Text)
import qualified Data.Text                          as T
import qualified Data.Text.Encoding                 as TE
import qualified Data.Text.Lazy                     as LT
import qualified Data.Text.Lazy.Encoding            as LT
import           Data.Word                          (Word8)
import           System.Exit
import           System.FilePath                    (takeFileName)
import           System.IO
import           System.Process
import           System.Random

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