{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{- |
MIME messages (RFC 2045, RFC 2046, RFC 2183 and friends).
This module extends "Data.RFC5322" with types for handling MIME
messages. It provides the 'mime' parsing helper function for
use with 'message'.
-}
module Data.MIME
(
-- * Overview / HOWTO
-- ** Creating and serialising mail
-- $create
-- ** Parsing mail
-- $parse
-- ** Inspecting messages
-- $inspect
-- ** Unicode support
-- $unicode
-- * API
-- ** MIME data type
MIME(..)
, mime
, MIMEMessage
, WireEntity
, ByteEntity
, TextEntity
, EncStateWire
, EncStateByte
-- *** Accessing and processing entities
, entities
, attachments
, isAttachment
, transferDecoded
, 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
-- ** Mail creation
-- *** Common use cases
, createTextPlainMessage
, createAttachment
, createAttachmentFromFile
, createMultipartMixedMessage
, encapsulate
-- *** Setting headers
, headerFrom
, headerTo
, headerCC
, headerBCC
, headerDate
, headerSubject
, headerText
, replyHeaderReferences
-- * Re-exports
, CharsetLookup
, defaultCharsets
, module Data.RFC5322
, module Data.MIME.Parameter
, module Data.MIME.Error
) where
import Control.Applicative
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty, fromList, intersperse)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Semigroup ((<>))
import Data.String (IsString(fromString))
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 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, parseTimeM)
import Data.RFC5322
import Data.RFC5322.Internal hiding (takeWhile1)
import Data.MIME.Error
import Data.MIME.Charset
import Data.MIME.EncodedWord
import Data.MIME.Parameter
import Data.MIME.TransferEncoding
{- $create
Create an __inline, plain text message__ and __render__ it:
@
λ> import Data.MIME
λ> msg = 'createTextPlainMessage' "Hello, world!"
λ> s = 'renderMessage' msg
λ> L.putStrLn s
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
Content-Type: text/plain; charset=us-ascii
Hello, world!
@
Set the __@From@__ and __@To@__ headers:
@
λ> alice = Mailbox Nothing (AddrSpec "alice" (DomainDotAtom ("example" :| ["com"])))
λ> bob = Mailbox Nothing (AddrSpec "bob" (DomainDotAtom ("example" :| ["net"])))
λ> msgFromAliceToBob = set ('headerFrom' 'defaultCharsets' [alice] . set ('headerTo' defaultCharsets) [Single bob] $ msg
λ> L.putStrLn (renderMessage msgFromAliceToBob)
MIME-Version: 1.0
From: alice@example.com
To: bob@example.net
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
Content-Type: text/plain; charset=us-ascii
Hello, world!
@
The 'headerFrom', 'headerTo', 'headerCC' and 'headerBCC' lenses are the most
convenient interface for reading and setting the __sender and recipient addresses__.
Note that you would usually not manually construct email addresses
manually as was done above. Instead you would usually read it from another
email or configuration, or parse addresses from user input.
The __@Subject@__ header is set via 'headerSubject'. __Other single-valued headers__
can be set via 'headerText'.
@
λ> :{
| L.putStrLn . renderMessage $
| set ('headerText' defaultCharsets "Comments") (Just "와")
| . set ('headerSubject' defaultCharsets) (Just "Hi from Alice")
| $ msgFromAliceToBob
| :}
MIME-Version: 1.0
Comments: =?utf-8?B?7JmA?=
Subject: Hi from Alice
From: alice@example.com
To: bob@example.net
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
Content-Type: text/plain; charset=us-ascii
Hello, world!
@
Create a __multipart message with attachment__:
@
λ> attachment = 'createAttachment' "application/json" (Just "data.json") "{\"foo\":42}"
λ> msg2 = 'createMultipartMixedMessage' "boundary" [msg, attachment]
λ> s2 = 'renderMessage' msg2
λ> L.putStrLn s2
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary=boundary
--boundary
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
Content-Type: text/plain; charset=us-ascii
Hello, world!
--boundary
Content-Transfer-Encoding: 7bit
Content-Disposition: attachment; filename=data.json
Content-Type: application/json
{"foo":42}
--boundary--
@
__NOTE:__ if you only need to write a serialised 'Message' to an
IO handle, 'buildMessage' is more efficient than 'renderMessage'.
-}
{- $parse
Most often you will __parse a message__ like this:
@
λ> parsedMessage = 'parse' ('message' 'mime') s2
λ> :t parsedMessage
parsedMessage :: Either String 'MIMEMessage'
λ> parsedMessage == Right msg2
True
@
The 'message' function builds a parser for a message. It is
abstracted over the body type; the argument is a function that can
inspect headers and return a parser for the body. If you are
parsing MIME messages (or plain RFC 5322 messages), the 'mime'
function is the right one to use.
-}
{- $inspect
Parsing an email is nice, but your normally want to get at the
content inside. One of the most important tasks is __finding entities__
of interest, e.g. attachments, plain text or HTML bodies. The
'entities' optic is a fold over all /leaf/ entities in the message.
That is, all the non-multipart bodies. You can use 'filtered' to
refine the query.
For example, let's say you want to find the first @text/plain@
entity in a message. Define a predicate with the help of the
'matchContentType' function:
@
λ> isTextPlain = 'matchContentType' "text" (Just "plain") . view 'contentType'
λ> :t isTextPlain
isTextPlain :: HasHeaders s => s -> Bool
λ> isTextPlain msg
True
λ> isTextPlain msg2
False
@
Now we can use the predicate to construct a fold and retrieve the
body. If there is no matching entity the result would be @Nothing@.
@
λ> firstOf ('entities' . filtered isTextPlain . 'body') msg2
Just "Hello, world!"
@
For __attachments__ you are normally interested in the binary data
and possibly the filename (if specified). In the following example
we retrieve all attachments, and their filenames, as a list of
tuples (although there is only one in the message). Note that
Get the (optional) filenames and (decoded) body of all attachments,
as a list of tuples. The 'attachments' optic selects non-multipart
entities with @Content-Disposition: attachment@. The 'attachments'
fold targets all entities with @Content-Disposition: attachment@.
The 'transferDecoded'' optic undoes the @Content-Transfer-Encoding@
of the entity.
@
λ> getFilename = preview ('contentDisposition' . _Just . 'filename' 'defaultCharsets')
λ> getBody = preview ('transferDecoded'' . _Right . 'body')
λ> getAttachment = liftA2 (,) getFilename getBody
λ> toListOf ('attachments' . to getAttachment) msg2
[(Just "data.json",Just "{\"foo\":42}")]
@
Finally, note that the 'filename' optic takes an argument: it is a
function for looking up a character set. Supporting every possible
character encoding is a bit tricky so we let the user supply a map
of supported charsets, and provide 'defaultCharsets' which supports
ASCII, UTF-8 and ISO-8859-1.
@
λ> :t 'filename'
filename
:: ('HasParameters' a, Applicative f) =>
'CharsetLookup' -> (T.Text -> f T.Text) -> a -> f a
λ> :t 'defaultCharsets'
defaultCharsets :: CharsetLookup
λ> :i CharsetLookup
type CharsetLookup = CI Char8.ByteString -> Maybe Data.MIME.Charset.Charset
@
-}
{- $unicode
In Australia we say "Hello world" upside down:
@
λ> msg3 = createTextPlainMessage "ɥǝןןo ʍoɹןp"
λ> L.putStrLn $ renderMessage msg3
MIME-Version: 1.0
Content-Transfer-Encoding: base64
Content-Disposition: inline
Content-Type: text/plain; charset=utf-8
yaXHndef159vIMqNb8m5159w
@
Charset set and transfer encoding are handled automatically. If the
message only includes characters representable in ASCII, the charset
will be @us-ascii@, otherwise @utf-8@.
To read the message as @Text@ you must perform transfer decoding and
charset decoding. The 'transferDecoded' optic performs transfer
decoding, as does its sibling 'transferDecoded'' which is
monomorphic in the error type. Similarly, 'charsetText' and
'charsetText'' perform text decoding according to the character set.
If you don't mind throwing away decoding errors, the simplest way to
get the text of a message is:
@
λ> Just ent = firstOf ('entities' . filtered isTextPlain) msg3
λ> :t ent
ent :: 'WireEntity'
λ> text = preview ('transferDecoded'' . _Right . 'charsetText'' 'defaultCharsets' . _Right) ent
λ> :t text
text :: Maybe T.Text
λ> traverse_ T.putStrLn text
ɥǝןןo ʍoɹןp
@
As mentioned earlier, functions that perform text decoding take a
'CharsetLookup' parameter, and we provide 'defaultCharsets' for
convenience.
-}
-- | 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
| Encapsulated MIMEMessage
| Multipart (NonEmpty MIMEMessage)
| FailedParse MIMEParseError B.ByteString
deriving (Eq, Show)
-- | Ignores the presence/absense of @MIME-Version@ header
instance EqMessage MIME where
Message h1 b1 `eqMessage` Message h2 b2 =
stripVer h1 == stripVer h2 && b1 == b2
where
stripVer = set (headers . at "MIME-Version") Nothing
-- | Get all leaf entities from the MIME message.
-- Entities that failed to parse are skipped.
--
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)
Encapsulated msg -> Message h . Encapsulated <$> entities f msg
Multipart bs ->
Message h . Multipart <$> sequenceA (entities f <$> bs)
FailedParse _ _ -> pure (Message h a)
-- | Leaf entities with @Content-Disposition: attachment@
attachments :: Traversal' MIMEMessage WireEntity
attachments = entities . filtered isAttachment
-- | MIMEMessage content disposition is an 'Attachment'
isAttachment :: HasHeaders a => a -> Bool
isAttachment = has (contentDisposition . _Just . dispositionType . filtered (== Attachment))
contentTransferEncoding
:: (Profunctor p, Contravariant f) => Optic' p f 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
transferEncode (Message h s) =
let
(cteName, cte) = chooseTransferEncoding s
s' = review (clonePrism cte) s
cteName' = CI.original cteName
h' = set (headers . at "Content-Transfer-Encoding") (Just cteName') h
in
Message h' s'
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" (Parameters [("charset", "utf-8")])
-- @
--
-- You can also use @-XOverloadedStrings@ but be aware the conversion
-- is non-total (throws an error if it cannot parse the string).
--
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'
-- | __NON-TOTAL__ parses the Content-Type (including parameters)
-- and throws an error if the parse fails
--
instance IsString ContentType where
fromString = either err id . parseOnly parseContentType . C8.pack
where
err msg = error $ "failed to parse Content-Type: " <> msg
-- | 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 . parameter "charset") (Just 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" mempty
-- | @application/octet-stream@
contentTypeApplicationOctetStream :: ContentType
contentTypeApplicationOctetStream =
ContentType "application" "octet-stream" mempty
-- | @multipart/mixed; boundary=asdf@
contentTypeMultipartMixed :: B.ByteString -> ContentType
contentTypeMultipartMixed boundary =
set (parameter "boundary") (Just (ParameterValue Nothing Nothing boundary))
$ ContentType "multipart" "mixed" mempty
-- | 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 :: HasHeaders a => Lens' a ContentType
contentType = headers . 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"
-- | Access @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/.
--
-- This optic does not distinguish between missing header or malformed
-- value.
--
contentDisposition :: HasHeaders a => Lens' a (Maybe ContentDisposition)
contentDisposition = headers . at "Content-Disposition" . dimap
(>>= either (const Nothing) Just . Data.RFC5322.parse parseContentDisposition)
(fmap . fmap $ 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
-- treats them as a single part.
--
mime :: Headers -> BodyHandler MIME
mime h
| nullOf (header "MIME-Version") h = RequiredBody (Part <$> takeByteString)
| otherwise = mime' takeByteString h
type instance MessageContext MIME = EncStateWire
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
-> BodyHandler MIME
mime' takeTillEnd h = RequiredBody $ case view contentType h of
ct | view ctType ct == "multipart" ->
case preview (rawParameter "boundary") ct of
Nothing -> FailedParse MultipartBoundaryNotSpecified <$> takeTillEnd
Just boundary ->
(Multipart <$> multipart takeTillEnd boundary)
<|> (FailedParse MultipartParseFail <$> takeTillEnd)
| matchContentType "message" (Just "rfc822") ct ->
(Encapsulated <$> message (mime' takeTillEnd))
<|> (FailedParse EncapsulatedMessageParseFail <$> takeTillEnd)
_ -> part
where
part = Part <$> takeTillEnd
data MIMEParseError
= MultipartBoundaryNotSpecified
| MultipartParseFail
| EncapsulatedMessageParseFail
deriving (Eq, Show)
-- | 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 (NonEmpty MIMEMessage)
multipart takeTillEnd boundary =
skipTillString dashBoundary *> crlf -- FIXME transport-padding
*> fmap fromList (part `sepBy1` crlf)
<* string "--" <* takeTillEnd
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
-- | Sets the @MIME-Version: 1.0@ header.
--
instance RenderMessage MIME where
tweakHeaders = set (headers . at "MIME-Version") (Just "1.0")
buildBody h z = Just $ case z of
Part partbody -> Builder.byteString partbody
Encapsulated msg -> buildMessage msg
Multipart xs ->
let b = firstOf (contentType . mimeBoundary) h
boundary = maybe mempty (\b' -> "--" <> Builder.byteString b') b
in
boundary <> "\r\n"
<> fold (intersperse ("\r\n" <> boundary <> "\r\n") (fmap buildMessage xs))
<> "\r\n" <> boundary <> "--\r\n"
FailedParse _ bs -> Builder.byteString bs
-- | Map a single-occurrence header to a list value.
-- On read, absent header is mapped to empty list.
-- On write, empty list results in absent header.
--
headerSingleToList
:: (HasHeaders s)
=> (B.ByteString -> [a])
-> ([a] -> B.ByteString)
-> CI B.ByteString
-> Lens' s [a]
headerSingleToList f g k =
headers . at k . iso (maybe [] f) (\l -> if null l then Nothing else Just (g l))
headerFrom :: HasHeaders a => CharsetLookup -> Lens' a [Mailbox]
headerFrom charsets = headerSingleToList
(either (const []) id . parseOnly (mailboxList charsets))
renderMailboxes
"From"
headerAddressList :: (HasHeaders a) => CI B.ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList k charsets = headerSingleToList
(either (const []) id . parseOnly (addressList charsets))
renderAddresses
k
headerTo, headerCC, headerBCC :: (HasHeaders a) => CharsetLookup -> Lens' a [Address]
headerTo = headerAddressList "To"
headerCC = headerAddressList "Cc"
headerBCC = headerAddressList "Bcc"
headerDate :: HasHeaders a => Lens' a (Maybe UTCTime)
headerDate = headers . at "Date" . iso (parseDate =<<) (fmap renderRFC5422Date)
where
parseDate =
parseTimeM True defaultTimeLocale rfc5422DateTimeFormatLax . C8.unpack
-- | Single-valued header with @Text@ value via encoded-words.
-- The conversion to/from Text is total (encoded-words that failed to be
-- decoded are passed through unchanged). Therefore @Nothing@ means that
-- the header was not present.
--
-- This function is suitable for the @Subject@ header.
--
headerText :: (HasHeaders a) => CharsetLookup -> CI B.ByteString -> Lens' a (Maybe T.Text)
headerText charsets k =
headers . at k . iso (fmap (decodeEncodedWords charsets)) (fmap encodeEncodedWords)
-- | Subject header. See 'headerText' for details of conversion to @Text@.
headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)
headerSubject charsets = headerText charsets "Subject"
-- | 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 :: HasHeaders a => Getter a (Maybe C8.ByteString)
replyHeaderReferences = (.) headers $ 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`
--
createMultipartMixedMessage
:: B.ByteString -- ^ Boundary
-> NonEmpty MIMEMessage -- ^ parts
-> MIMEMessage
createMultipartMixedMessage b attachments' =
let hdrs = mempty &
set contentType (contentTypeMultipartMixed b)
in Message hdrs (Multipart attachments')
-- | Create an inline, text/plain, utf-8 encoded message
--
createTextPlainMessage :: T.Text -> MIMEMessage
createTextPlainMessage s = fmap Part $ transferEncode $ charsetEncode msg
where
msg = Message hdrs s :: TextEntity
cd = ContentDisposition Inline mempty
hdrs = mempty
& set contentType contentTypeTextPlain
& set contentDisposition (Just cd)
-- | 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
-- filename parameter to the given file path.
--
createAttachment :: ContentType -> Maybe FilePath -> B.ByteString -> MIMEMessage
createAttachment ct fp s = Part <$> transferEncode msg
where
msg = Message hdrs s
cd = ContentDisposition Attachment cdParams
cdParams = mempty & set filenameParameter (newParameter <$> fp)
hdrs = mempty
& set contentType ct
& set contentDisposition (Just cd)
-- | Encapsulate a message as a @message/rfc822@ message.
-- You can use this in creating /forwarded/ or /bounce/ messages.
--
encapsulate :: MIMEMessage -> MIMEMessage
encapsulate = Message hdrs . Encapsulated
where
hdrs = mempty & set contentType "message/rfc822"