{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}

{- |

MIME messages (RFC 2045, RFC 2046 and friends).

-}
module Data.MIME
  (
  -- * Overview
  -- $overview

  -- * Examples / HOWTO
  -- $examples

  -- * API

  -- ** MIME data type
    MIME(..)
  , mime
  , MIMEMessage

  , WireEntity
  , ByteEntity
  , TextEntity
  , EncStateWire
  , EncStateByte

  -- *** Accessing and processing entities
  , entities
  , attachments
  , isAttachment
  , transferDecoded
  , charsetDecoded

  -- ** Header processing
  , decodeEncodedWords

  -- ** Content-Type header
  , contentType
  , ContentType(..)
  , ctType
  , ctSubtype
  , matchContentType
  , ctEq
  , parseContentType
  , showContentType
  , mimeBoundary

  -- *** Content-Type values
  , contentTypeTextPlain
  , contentTypeApplicationOctetStream
  , contentTypeMultipartMixed
  , defaultContentType

  -- ** Content-Disposition header
  , contentDisposition
  , ContentDisposition(..)
  , DispositionType(..)
  , dispositionType
  , filename
  , filenameParameter

  -- ** Serialisation
  , renderMessage
  , buildMessage

  -- ** Mail creation
  , headerFrom
  , headerTo
  , headerCC
  , headerBCC
  , headerDate
  , replyHeaderReferences
  , createAttachmentFromFile
  , createAttachment
  , createTextPlainMessage
  , createMultipartMixedMessage

  -- * Re-exports
  , CharsetLookup
  , defaultCharsets
  , module Data.RFC5322
  , module Data.MIME.Parameter
  , module Data.MIME.Error
  ) where

import Control.Applicative
import Control.Monad (void)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Semigroup ((<>))
import GHC.Generics (Generic)

import Control.DeepSeq (NFData)
import Control.Lens
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8 (char8)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Builder as Builder
import Data.ByteString.Lazy (toStrict)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock (UTCTime)
import Data.Time.Format (defaultTimeLocale, parseTimeOrError)

import Data.RFC5322
import Data.RFC5322.Internal
import Data.MIME.Error
import Data.MIME.Charset
import Data.MIME.EncodedWord
import Data.MIME.Parameter
import Data.MIME.TransferEncoding
import Data.MIME.Types (Encoding(..))

{- $overview

This module extends 'Data.RFC5322' with types for handling MIME
messages.  It provides the 'mime' parsing helper function for
use with 'message'.

@
'mime' :: Headers -> Parser MIME
message mime :: Parser (Message ctx MIME)
@

The 'Message' data type has a phantom type parameter for context.
In this module we use it to track whether the body has
/content transfer encoding/ or /charset encoding/ applied.  Type
aliases are provided for convenince.

@
data 'Message' ctx a = Message Headers a
data 'EncStateWire'
data 'EncStateByte'

type 'MIMEMessage' = Message EncStateWire MIME
type 'WireEntity' = Message EncStateWire B.ByteString
type 'ByteEntity' = Message EncStateByte B.ByteString
type 'TextEntity' = Message () T.Text
@

Folds are provided over all leaf /entities/, and entities that are
identified as attachments:

@
'entities' :: Fold MIMEMessage WireEntity
'attachments' :: Fold MIMEMessage WireEntity
@

Content transfer decoding is performed using the 'transferDecoded'
optic.  This will convert /Quoted-Printable/ or /Base64/ encoded
entities into their decoded form.

@
'transferDecoded' :: Getter WireEntity (Either 'TransferEncodingError' ByteEntity)
transferDecoded :: Getter WireEntity (Either 'EncodingError' ByteEntity)
transferDecoded :: (HasTransferEncoding a, AsTransferEncodingError e) => Getter a (Either e (TransferDecoded a))
@

Charset decoding is performed using the 'charsetDecoded' optic:

@
'charsetDecoded' :: Getter ByteEntity (Either 'CharsetError' TextEntity)
charsetDecoded :: Getter ByteEntity (Either 'EncodingError' TextEntity)
charsetDecoded :: (HasCharset a, AsCharsetError e) => Getter a (Either e (Decoded a))
@

-}

{- $examples

__Parse__ a MIME message:

@
'parse' (message mime) :: ByteString -> Either String MIMEMessage
@

Find the first entity with the @text/plain@ __content type__:

@
getTextPlain :: 'MIMEMessage' -> Maybe 'WireEntity'
getTextPlain = firstOf ('entities' . filtered f)
  where
  f = 'matchContentType' "text" (Just "plain") . view ('headers' . 'contentType')
@

Perform __content transfer decoding__ /and/ __charset__ decoding
while preserving decode errors:

@
view 'transferDecoded' >=> view 'charsetDecoded' :: WireEntity -> Either EncodingError TextEntity
@

Get all __attachments__ (transfer decoded) and their __filenames__ (if specified):

@
getAttachments :: 'MIMEMessage' -> [(Either 'TransferEncodingError' B.ByteString, Maybe T.Text)]
getAttachments = toListOf ('attachments' . to (liftA2 (,) content name)
  where
  content = view 'transferDecodedBytes'
  name = preview ('headers' . 'contentDisposition' . 'filename')
@

Create an inline, plain text message and render it:

@
renderMessage $ createTextPlainMessage "This is a test body"
@
-}


-- | Entity is formatted for transfer.  Processing requires
-- transfer decoding.
--
data EncStateWire

-- | Entity requires content-transfer-encoding to send,
--   and may require charset decoding to read.
--
data EncStateByte

type MIMEMessage = Message EncStateWire MIME
type WireEntity = Message EncStateWire B.ByteString
type ByteEntity = Message EncStateByte B.ByteString
type TextEntity = Message () T.Text

-- | MIME message body.  Either a single @Part@, or @Multipart@.
-- Only the body is represented; preamble and epilogue are not.
--
data MIME
  = Part B.ByteString
  | Multipart [MIMEMessage]
  deriving (Eq, Show)

-- | Get all leaf entities from the MIME message
--
entities :: Traversal' MIMEMessage WireEntity
entities f (Message h a) = case a of
  Part b ->
    (\(Message h' b') -> Message h' (Part b')) <$> f (Message h b)
  Multipart bs ->
    Message h . Multipart <$> sequenceA (entities f <$> bs)

-- | Leaf entities with @Content-Disposition: attachment@
attachments :: Traversal' MIMEMessage WireEntity
attachments = entities . filtered (notNullOf l) where
  l = headers . contentDisposition . dispositionType . filtered (== Attachment)

-- | MIMEMessage content disposition is an 'Attachment'
isAttachment :: MIMEMessage -> Bool
isAttachment = has (headers . contentDisposition . dispositionType . filtered (== Attachment))

contentTransferEncoding :: Getter Headers TransferEncodingName
contentTransferEncoding = to $
  fromMaybe "7bit"
  . preview (header "content-transfer-encoding" . caseInsensitive)

instance HasTransferEncoding WireEntity where
  type TransferDecoded WireEntity = ByteEntity
  transferEncodingName = headers . contentTransferEncoding
  transferEncodedData = body
  transferDecoded = to $ \a -> (\t -> set body t a) <$> view transferDecodedBytes a

printContentTransferEncoding :: Encoding -> B.ByteString
printContentTransferEncoding Base64 = "base64"
printContentTransferEncoding None = "7bit"

caseInsensitive :: CI.FoldCase s => Iso' s (CI s)
caseInsensitive = iso CI.mk CI.original
{-# INLINE caseInsensitive #-}


-- | Content-Type header (RFC 2183).
-- Use 'parameters' to access the parameters.
-- Example:
--
-- @
-- ContentType "text" "plain" [("charset", "utf-8")]
-- @
--
data ContentType = ContentType (CI B.ByteString) (CI B.ByteString) Parameters
  deriving (Show, Generic, NFData)

-- | Equality of Content-Type. Type and subtype are compared
-- case-insensitively and parameters are also compared.  Use
-- 'matchContentType' if you just want to match on the media type
-- while ignoring parameters.
--
instance Eq ContentType where
  ContentType a b c == ContentType a' b' c' = a == a' && b == b' && c == c'

-- | Match content type.  If @Nothing@ is given for subtype, any
-- subtype is accepted.
--
matchContentType
  :: CI B.ByteString         -- ^ type
  -> Maybe (CI B.ByteString) -- ^ optional subtype
  -> ContentType
  -> Bool
matchContentType wantType wantSubtype (ContentType gotType gotSubtype _) =
  wantType == gotType && maybe True (== gotSubtype) wantSubtype

printContentType :: ContentType -> B.ByteString
printContentType (ContentType typ sub params) =
  CI.original typ <> "/" <> CI.original sub <> printParameters params

printParameters :: Parameters -> B.ByteString
printParameters (Parameters xs) =
  foldMap (\(k,v) -> "; " <> CI.original k <> "=" <> v) xs

-- | Are the type and subtype the same? (parameters are ignored)
--
ctEq :: ContentType -> ContentType -> Bool
ctEq (ContentType typ1 sub1 _) = matchContentType typ1 (Just sub1)
{-# DEPRECATED ctEq "Use 'matchContentType' instead" #-}

ctType :: Lens' ContentType (CI B.ByteString)
ctType f (ContentType a b c) = fmap (\a' -> ContentType a' b c) (f a)

ctSubtype :: Lens' ContentType (CI B.ByteString)
ctSubtype f (ContentType a b c) = fmap (\b' -> ContentType a b' c) (f b)

ctParameters :: Lens' ContentType Parameters
ctParameters f (ContentType a b c) = fmap (\c' -> ContentType a b c') (f c)
{-# ANN ctParameters ("HLint: ignore Avoid lambda" :: String) #-}

-- | Rendered content type field value for displaying
showContentType :: ContentType -> T.Text
showContentType = decodeLenient . printContentType

instance HasParameters ContentType where
  parameters = ctParameters

-- | Parser for Content-Type header
parseContentType :: Parser ContentType
parseContentType = do
  typ <- ci token
  _ <- char8 '/'
  subtype <- ci token
  params <- parseParameters
  if typ == "multipart" && "boundary" `notElem` fmap fst params
    then
      -- https://tools.ietf.org/html/rfc2046#section-5.1.1
      fail "\"boundary\" parameter is required for multipart content type"
    else pure $ ContentType typ subtype (Parameters params)

parseParameters :: Parser [(CI B.ByteString, B.ByteString)]
parseParameters = many (char8 ';' *> skipWhile (== 32 {-SP-}) *> param)
  where
    param = (,) <$> ci token <* char8 '=' <*> val
    val = token <|> quotedString

-- | header token parser
token :: Parser B.ByteString
token =
  takeWhile1 (\c -> c >= 33 && c <= 126 && notInClass "()<>@,;:\\\"/[]?=" c)

-- | RFC 2046 §4.1.2. defines the default character set to be US-ASCII.
--
instance HasCharset ByteEntity where
  type Decoded ByteEntity = TextEntity
  charsetName = to $ \ent ->
    let
      (ContentType typ sub params) = view (headers . contentType) ent
      source = fromMaybe (InParameter (Just "us-ascii")) . (`lookup` textCharsetSources)
      l = rawParameter "charset" . caseInsensitive
    in
      if typ == "text"
      then case source sub of
        InBand f -> f (view body ent)
        InParameter def -> preview l params <|> def
        InBandOrParameter f def -> f (view body ent) <|> preview l params <|> def
      else
        preview l params <|> Just "us-ascii"
  charsetData = body -- XXX: do we need to drop the BOM / encoding decl?
  charsetDecoded m = to $ \a -> (\t -> set body t a) <$> view (charsetText m) a

  -- | Encode (@utf-8@) and add/set charset parameter.  If consisting
  -- entirely of ASCII characters, the @charset@ parameter gets set to
  -- @us-ascii@ instead of @utf-8@.
  --
  -- Ignores Content-Type (which is not correct for all content types).
  --
  charsetEncode (Message h a) =
    let
      b = T.encodeUtf8 a
      charset = if B.all (< 0x80) b then "us-ascii" else "utf-8"
    in Message (set (contentType . rawParameter "charset") charset h) b

-- | RFC 6657 provides for different media types having different
-- ways to determine the charset.  This data type defines how a
-- charset should be determined for some media type.
--
data EntityCharsetSource
  = InBand (B.ByteString -> Maybe CharsetName)
  -- ^ Charset should be declared within payload (e.g. xml, rtf).
  --   The given function reads it from the payload.
  | InParameter (Maybe CharsetName)
  -- ^ Charset should be declared in the 'charset' parameter,
  --   with optional fallback to the given default.
  | InBandOrParameter (B.ByteString -> Maybe CharsetName) (Maybe CharsetName)
  -- ^ Check in-band first, fall back to 'charset' parameter,
  --   and further optionally fall back to a default.

-- | Charset sources for text/* media types.  IANA registry:
-- https://www.iana.org/assignments/media-types/media-types.xhtml#text
--
textCharsetSources :: [(CI B.ByteString, EntityCharsetSource)]
textCharsetSources =
  [ ("plain", InParameter (Just "us-ascii"))
  , ("csv", InParameter (Just "utf-8"))
  , ("rtf", InBand (const (Just "us-ascii" {- TODO -})))

  -- https://tools.ietf.org/html/rfc2854
  -- The default is ambiguous; using us-ascii for now
  , ("html", InBandOrParameter (const Nothing {-TODO-}) (Just "us-ascii"))

  -- https://tools.ietf.org/html/rfc7763
  , ("markdown", InParameter Nothing)

  -- https://tools.ietf.org/html/rfc7303#section-3.2 and
  -- https://www.w3.org/TR/2008/REC-xml-20081126/#charencoding
  , ("xml", InBand (const (Just "utf-8") {-TODO-}))
  ]

-- | @text/plain; charset=us-ascii@
defaultContentType :: ContentType
defaultContentType =
  over parameterList (("charset", "us-ascii"):) contentTypeTextPlain

-- | @text/plain@
contentTypeTextPlain :: ContentType
contentTypeTextPlain = ContentType "text" "plain" (Parameters [])

-- | @application/octet-stream@
contentTypeApplicationOctetStream :: ContentType
contentTypeApplicationOctetStream =
  ContentType "application" "octet-stream" (Parameters [])

-- | @multipart/mixed; boundary=asdf@
contentTypeMultipartMixed :: B.ByteString -> ContentType
contentTypeMultipartMixed boundary =
  over parameterList (("boundary", boundary):)
  $ ContentType "multipart" "mixed" (Parameters [])

-- | Lens to the content-type header.  Probably not a lawful lens.
--
-- If the header is not specified or is syntactically invalid,
-- 'defaultContentType' is used.  For more info see
-- <https://tools.ietf.org/html/rfc2045#section-5.2>.
--
-- If the Content-Transfer-Encoding is unrecognised, the
-- actual Content-Type value is ignored and
-- @application/octet-stream@ is returned, as required by
-- <https://tools.ietf.org/html/rfc2049#section-2>.
--
-- When setting, if the header already exists it is replaced,
-- otherwise it is added.  Unrecognised Content-Transfer-Encoding
-- is ignored when setting.
--
contentType :: Lens' Headers ContentType
contentType = lens sa sbt where
  sa s = case view cte s of
    Nothing -> contentTypeApplicationOctetStream
    Just _ ->
      fromMaybe defaultContentType $ preview (ct . parsed parseContentType) s

  sbt s b = set (at "Content-Type") (Just (printContentType b)) s

  ct = header "content-type"
  cte = contentTransferEncoding . to (`lookup` transferEncodings)

-- | Content-Disposition header (RFC 2183).
--
-- Use 'parameters' to access the parameters.
--
data ContentDisposition = ContentDisposition
  DispositionType   -- disposition
  Parameters        -- parameters
  deriving (Show, Generic, NFData)

data DispositionType = Inline | Attachment
  deriving (Eq, Show, Generic, NFData)

dispositionType :: Lens' ContentDisposition DispositionType
dispositionType f (ContentDisposition a b) =
  fmap (\a' -> ContentDisposition a' b) (f a)
{-# ANN dispositionType ("HLint: ignore Avoid lambda" :: String) #-}

dispositionParameters :: Lens' ContentDisposition Parameters
dispositionParameters f (ContentDisposition a b) =
  fmap (\b' -> ContentDisposition a b') (f b)
{-# ANN dispositionParameters ("HLint: ignore Avoid lambda" :: String) #-}

instance HasParameters ContentDisposition where
  parameters = dispositionParameters

-- | Parser for Content-Disposition header
--
-- Unrecognised disposition types are coerced to @Attachment@
-- in accordance with RFC 2183 §2.8 which states: /Unrecognized disposition
-- types should be treated as /attachment//.
parseContentDisposition :: Parser ContentDisposition
parseContentDisposition = ContentDisposition
  <$> (mapDispType <$> ci token)
  <*> (Parameters <$> parseParameters)
  where
    mapDispType s
      | s == "inline" = Inline
      | otherwise = Attachment

printContentDisposition :: ContentDisposition -> B.ByteString
printContentDisposition (ContentDisposition typ params) =
  typStr <> printParameters params
  where
    typStr = case typ of Inline -> "inline" ; Attachment -> "attachment"

-- | Get Content-Disposition header.
-- Unrecognised disposition types are coerced to @Attachment@
-- in accordance with RFC 2183 §2.8 which states:
-- /Unrecognized disposition types should be treated as/ attachment.
--
-- The fold may be empty, e.g. if the header is absent or unparseable.
--
contentDisposition :: Traversal' Headers ContentDisposition
contentDisposition =
  header "content-disposition"
  . parsePrint parseContentDisposition printContentDisposition

-- | Traverse the value of the filename parameter (if present).
--
filename :: HasParameters a => CharsetLookup -> Traversal' a T.Text
filename m = filenameParameter . traversed . charsetPrism m . value

-- | Access the filename parameter as a @Maybe ('ParameterValue' B.ByteString)@.
--
-- This can be used to read or set the filename parameter (see also
-- the 'newParameter' convenience function):
--
-- @
-- λ> let hdrs = Headers [("Content-Disposition", "attachment")]
-- λ> set ('contentDisposition' . 'filenameParameter') (Just ('newParameter' "foo.txt")) hdrs
-- Headers [("Content-Disposition","attachment; filename=foo.txt")]
-- @
filenameParameter :: HasParameters a => Lens' a (Maybe EncodedParameterValue)
filenameParameter = parameter "filename"


-- | Get the boundary, if specified
mimeBoundary :: Traversal' ContentType B.ByteString
mimeBoundary = parameters . rawParameter "boundary"

-- | Top-level MIME body parser that uses headers to decide how to
--   parse the body.
--
-- __Do not use this parser for parsing a nested message.__
-- This parser should only be used when the message you want to
-- parse is the /whole input/.  If you use it to parse a nested
-- message it will treat the remainder of the outer message(s)
-- as part of the epilogue.
--
-- Preambles and epilogues are discarded.
--
-- This parser accepts non-MIME messages, and unconditionally
-- treats them as a single part.
--
mime :: Headers -> Parser MIME
mime h
  | nullOf (header "MIME-Version") h = Part <$> takeByteString
  | otherwise = mime' takeByteString h

mime'
  :: Parser B.ByteString
  -- ^ Parser FOR A TAKE to the part delimiter.  If this part is
  -- multipart, we pass it on to the 'multipart' parser.  If this
  -- part is not multipart, we just do the take.
  -> Headers
  -> Parser MIME
mime' takeTillEnd h = case view contentType h of
  ct | view ctType ct == "multipart" ->
    case preview (rawParameter "boundary") ct of
      Nothing -> part
      Just boundary -> Multipart <$> multipart takeTillEnd boundary
  _ -> part
  where
    part = Part <$> takeTillEnd

-- | Parse a multipart MIME message.  Preambles and epilogues are
-- discarded.
--
multipart
  :: Parser B.ByteString  -- ^ parser to the end of the part
  -> B.ByteString         -- ^ boundary, sans leading "--"
  -> Parser [MIMEMessage]
multipart takeTillEnd boundary =
  multipartBody
  where
    delimiter = "\n--" <> boundary
    dashBoundary = B.tail delimiter
    part = message (mime' (trim <$> takeTillString delimiter))
    trim s  -- trim trailing CR, because we only searched for LF
      | B.null s = s
      | C8.last s == '\r' = B.init s
      | otherwise = s

    multipartBody =
      skipTillString dashBoundary *> crlf -- FIXME transport-padding
      *> part `sepBy` crlf
      <* string "--" <* takeTillEnd

-- | Serialise a given `MIMEMessage` into a ByteString. The message is
-- serialised as is. No additional headers are set.
renderMessage :: MIMEMessage -> B.ByteString
renderMessage = toStrict . Builder.toLazyByteString . buildMessage

-- | Serialise a given `MIMEMessage` using a `Builder`
buildMessage :: MIMEMessage -> Builder.Builder
buildMessage (Message h (Part partbody)) =
    buildFields h <> "\r\n" <> Builder.byteString partbody
buildMessage (Message h (Multipart xs)) =
    let b = firstOf (contentType . mimeBoundary) h
        boundary = maybe mempty (\b' -> "\r\n--" <> Builder.byteString b') b
        ents = foldMap (\part -> boundary <> "\r\n" <> buildMessage part) xs
    in buildFields h <> ents <> boundary <> "--\r\n"


mimeHeader :: (CI B.ByteString, B.ByteString)
mimeHeader = (CI.mk "MIME-Version", "1.0")

-- | creates a new `MIMEMessage` and transfer encodes the given content with the
-- given Encoding
createMessage
    :: ContentType
    -> ContentDisposition
    -> Encoding
    -> B.ByteString -- ^ content
    -> MIMEMessage
createMessage ct cd encoding content =
  let m = Message (Headers [mimeHeader]) (Part $ transferEncodeData encoding content)
  in m
  & set (headers . at "Content-Type") (Just (printContentType ct))
  . set (headers . at "Content-Disposition") (Just (printContentDisposition cd))
  . set (headers . at "Content-Transfer-Encoding") (Just (printContentTransferEncoding encoding))

headerFrom :: Lens' Headers [Mailbox]
headerFrom = lens getter setter
  where
    getter = either (pure []) id . parseOnly mailboxList . view (header "from")
    setter = flip $ set (header "from") . renderMailboxes

headerTo :: Lens' Headers [Address]
headerTo = lens (headerGetter "to") (headerSetter "to")

headerCC :: Lens' Headers [Address]
headerCC = lens (headerGetter "cc") (headerSetter "cc")

headerBCC :: Lens' Headers [Address]
headerBCC = lens (headerGetter "bcc") (headerSetter "bcc")

headerSetter :: CI B.ByteString -> Headers -> [Address] -> Headers
headerSetter fieldname = flip $ set (header fieldname) . renderAddresses

headerGetter :: CI C8.ByteString -> Headers -> [Address]
headerGetter fieldname =
    either (pure []) id . parseOnly addressList . view (header fieldname)

headerDate :: Lens' Headers UTCTime
headerDate = lens getter setter
  where
    -- TODO for parseTimeOrError. See #16
    getter =
        parseTimeOrError True defaultTimeLocale rfc5422DateTimeFormat
        . C8.unpack . view (header "date")
    setter hdrs x = set (header "date") (renderRFC5422Date x) hdrs

-- | Returns a space delimited `B.ByteString` with values from identification
-- fields from the parents message `Headers`. Rules to gather the values are in
-- accordance to RFC5322 - 3.6.4 as follows sorted by priority (first has
-- precedence):
-- * Values from 'References' and `Message-ID` (if any)
-- * Values from 'In-Reply-To' and 'Message-ID' (if any)
-- * Value from 'Message-ID' (in case it's the first reply to a parent mail)
-- * otherwise Nothing is returned indicating that the replying mail should not have a 'References' field.
--
replyHeaderReferences :: Getter Headers (Maybe C8.ByteString)
replyHeaderReferences = to $ \hdrs ->
  let xs = catMaybes
        [preview (header "references") hdrs
         <|> preview (header "in-reply-to") hdrs
        , preview (header "message-id") hdrs
        ]
  in if null xs then Nothing else Just (B.intercalate " " xs)

-- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple
-- `attachments`
--
-- Additional headers can be set (e.g. 'cc') by using `At` and `Ixed`, for
-- example:
--
-- @
-- λ> set (at "subject") (Just "Hey there") $ Headers []
-- Headers [("subject", "Hey there")]
-- @
--
-- You can also use the `Mailbox` instances:
--
-- @
-- λ> let address = Mailbox (Just "roman") (AddrSpec "roman" (DomainLiteral "192.168.1.1"))
-- λ> set (at "cc") (Just $ renderMailbox address) $ Headers []
-- Headers [("cc", "\\"roman\\" <roman@192.168.1.1>")]
-- @
createMultipartMixedMessage
    :: B.ByteString -- ^ Boundary
    -> [MIMEMessage] -- ^ attachments
    -> MIMEMessage
createMultipartMixedMessage b attachments' =
    let hdrs =
            set
                (at "Content-Type")
                (Just $ printContentType (contentTypeMultipartMixed b)) $
            Headers [mimeHeader]
    in Message hdrs (Multipart attachments')

-- | Create an inline, text/plain, utf-8 encoded message
--
createTextPlainMessage
    :: T.Text -- ^ message body
    -> MIMEMessage
createTextPlainMessage =
    createMessage
        contentTypeTextPlain
        (ContentDisposition Inline $ Parameters [(CI.mk "charset", "utf-8")])
        None
    . T.encodeUtf8

-- | Create an attachment from a given file path.
-- Note: The filename content disposition is set to the given `FilePath`. For
-- privacy reasons, you can unset/change it. See `filename` for examples.
--
createAttachmentFromFile :: ContentType -> FilePath -> IO MIMEMessage
createAttachmentFromFile ct fp = createAttachment ct (Just fp) <$> B.readFile fp

-- | Create an attachment from the given file contents. Optionally set the given
-- filename parameter to the given file path.
--
createAttachment :: ContentType -> Maybe FilePath -> B.ByteString -> MIMEMessage
createAttachment ct fp =
    set
        (headers . contentDisposition . filenameParameter)
        (newParameter . T.pack <$> fp) .
    createMessage ct (ContentDisposition Attachment $ Parameters []) Base64