{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.MIME
(
MIME(..)
, mime
, MIMEMessage
, WireEntity
, ByteEntity
, TextEntity
, EncStateWire
, EncStateByte
, entities
, attachments
, isAttachment
, transferDecoded
, charsetDecoded
, decodeEncodedWords
, contentType
, ContentType(..)
, ctType
, ctSubtype
, matchContentType
, ctEq
, parseContentType
, showContentType
, mimeBoundary
, contentTypeTextPlain
, contentTypeApplicationOctetStream
, contentTypeMultipartMixed
, defaultContentType
, contentDisposition
, ContentDisposition(..)
, DispositionType(..)
, dispositionType
, filename
, filenameParameter
, renderMessage
, buildMessage
, headerFrom
, headerTo
, headerCC
, headerBCC
, headerDate
, replyHeaderReferences
, createAttachmentFromFile
, createAttachment
, createTextPlainMessage
, createMultipartMixedMessage
, 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(..))
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
data MIME
= Part B.ByteString
| Multipart [MIMEMessage]
deriving (Eq, Show)
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)
attachments :: Traversal' MIMEMessage WireEntity
attachments = entities . filtered (notNullOf l) where
l = headers . contentDisposition . dispositionType . filtered (== 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 #-}
data ContentType = ContentType (CI B.ByteString) (CI B.ByteString) Parameters
deriving (Show, Generic, NFData)
instance Eq ContentType where
ContentType a b c == ContentType a' b' c' = a == a' && b == b' && c == c'
matchContentType
:: CI B.ByteString
-> Maybe (CI B.ByteString)
-> 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
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) #-}
showContentType :: ContentType -> T.Text
showContentType = decodeLenient . printContentType
instance HasParameters ContentType where
parameters = ctParameters
parseContentType :: Parser ContentType
parseContentType = do
typ <- ci token
_ <- char8 '/'
subtype <- ci token
params <- parseParameters
if typ == "multipart" && "boundary" `notElem` fmap fst params
then
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 ) *> param)
where
param = (,) <$> ci token <* char8 '=' <*> val
val = token <|> quotedString
token :: Parser B.ByteString
token =
takeWhile1 (\c -> c >= 33 && c <= 126 && notInClass "()<>@,;:\\\"/[]?=" c)
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
charsetDecoded m = to $ \a -> (\t -> set body t a) <$> view (charsetText m) a
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
data EntityCharsetSource
= InBand (B.ByteString -> Maybe CharsetName)
| InParameter (Maybe CharsetName)
| InBandOrParameter (B.ByteString -> Maybe CharsetName) (Maybe CharsetName)
textCharsetSources :: [(CI B.ByteString, EntityCharsetSource)]
textCharsetSources =
[ ("plain", InParameter (Just "us-ascii"))
, ("csv", InParameter (Just "utf-8"))
, ("rtf", InBand (const (Just "us-ascii" )))
, ("html", InBandOrParameter (const Nothing ) (Just "us-ascii"))
, ("markdown", InParameter Nothing)
, ("xml", InBand (const (Just "utf-8") ))
]
defaultContentType :: ContentType
defaultContentType =
over parameterList (("charset", "us-ascii"):) contentTypeTextPlain
contentTypeTextPlain :: ContentType
contentTypeTextPlain = ContentType "text" "plain" (Parameters [])
contentTypeApplicationOctetStream :: ContentType
contentTypeApplicationOctetStream =
ContentType "application" "octet-stream" (Parameters [])
contentTypeMultipartMixed :: B.ByteString -> ContentType
contentTypeMultipartMixed boundary =
over parameterList (("boundary", boundary):)
$ ContentType "multipart" "mixed" (Parameters [])
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)
data ContentDisposition = ContentDisposition
DispositionType
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
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"
contentDisposition :: Traversal' Headers ContentDisposition
contentDisposition =
header "content-disposition"
. parsePrint parseContentDisposition printContentDisposition
filename :: HasParameters a => CharsetLookup -> Traversal' a T.Text
filename m = filenameParameter . traversed . charsetPrism m . value
filenameParameter :: HasParameters a => Lens' a (Maybe EncodedParameterValue)
filenameParameter = parameter "filename"
mimeBoundary :: Traversal' ContentType B.ByteString
mimeBoundary = parameters . rawParameter "boundary"
mime :: Headers -> Parser MIME
mime h
| nullOf (header "MIME-Version") h = Part <$> takeByteString
| otherwise = mime' takeByteString h
mime'
:: Parser B.ByteString
-> 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
multipart
:: Parser B.ByteString
-> B.ByteString
-> Parser [MIMEMessage]
multipart takeTillEnd boundary =
multipartBody
where
delimiter = "\n--" <> boundary
dashBoundary = B.tail delimiter
part = message (mime' (trim <$> takeTillString delimiter))
trim s
| B.null s = s
| C8.last s == '\r' = B.init s
| otherwise = s
multipartBody =
skipTillString dashBoundary *> crlf
*> part `sepBy` crlf
<* string "--" <* takeTillEnd
renderMessage :: MIMEMessage -> B.ByteString
renderMessage = toStrict . Builder.toLazyByteString . buildMessage
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")
createMessage
:: ContentType
-> ContentDisposition
-> Encoding
-> B.ByteString
-> 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
getter =
parseTimeOrError True defaultTimeLocale rfc5422DateTimeFormat
. C8.unpack . view (header "date")
setter hdrs x = set (header "date") (renderRFC5422Date x) hdrs
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)
createMultipartMixedMessage
:: B.ByteString
-> [MIMEMessage]
-> MIMEMessage
createMultipartMixedMessage b attachments' =
let hdrs =
set
(at "Content-Type")
(Just $ printContentType (contentTypeMultipartMixed b)) $
Headers [mimeHeader]
in Message hdrs (Multipart attachments')
createTextPlainMessage
:: T.Text
-> MIMEMessage
createTextPlainMessage =
createMessage
contentTypeTextPlain
(ContentDisposition Inline $ Parameters [(CI.mk "charset", "utf-8")])
None
. T.encodeUtf8
createAttachmentFromFile :: ContentType -> FilePath -> IO MIMEMessage
createAttachmentFromFile ct fp = createAttachment ct (Just fp) <$> B.readFile fp
createAttachment :: ContentType -> Maybe FilePath -> B.ByteString -> MIMEMessage
createAttachment ct fp =
set
(headers . contentDisposition . filenameParameter)
(newParameter . T.pack <$> fp) .
createMessage ct (ContentDisposition Attachment $ Parameters []) Base64