{-# 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
, transferDecoded'
, charsetDecoded
, decodeEncodedWords
, contentType
, ContentType(..)
, ctType
, ctSubtype
, matchContentType
, ctEq
, parseContentType
, showContentType
, mimeBoundary
, contentTypeTextPlain
, contentTypeApplicationOctetStream
, contentTypeMultipartMixed
, defaultContentType
, contentDisposition
, ContentDisposition(..)
, DispositionType(..)
, dispositionType
, filename
, filenameParameter
, createTextPlainMessage
, createAttachment
, createAttachmentFromFile
, createMultipartMixedMessage
, encapsulate
, headerFrom
, headerTo
, headerCC
, headerBCC
, headerDate
, headerSubject
, headerText
, replyHeaderReferences
, 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
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
| Encapsulated MIMEMessage
| Multipart (NonEmpty MIMEMessage)
| FailedParse MIMEParseError B.ByteString
deriving (Eq, Show)
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
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)
attachments :: Traversal' MIMEMessage WireEntity
attachments = entities . filtered isAttachment
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 #-}
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'
instance IsString ContentType where
fromString = either err id . parseOnly parseContentType . C8.pack
where
err msg = error $ "failed to parse Content-Type: " <> msg
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 . parameter "charset") (Just 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" mempty
contentTypeApplicationOctetStream :: ContentType
contentTypeApplicationOctetStream =
ContentType "application" "octet-stream" mempty
contentTypeMultipartMixed :: B.ByteString -> ContentType
contentTypeMultipartMixed boundary =
set (parameter "boundary") (Just (ParameterValue Nothing Nothing boundary))
$ ContentType "multipart" "mixed" mempty
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)
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 :: HasHeaders a => Lens' a (Maybe ContentDisposition)
contentDisposition = headers . at "Content-Disposition" . dimap
(>>= either (const Nothing) Just . Data.RFC5322.parse parseContentDisposition)
(fmap . fmap $ 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 -> 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
-> 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)
multipart
:: Parser B.ByteString
-> B.ByteString
-> Parser (NonEmpty MIMEMessage)
multipart takeTillEnd boundary =
skipTillString dashBoundary *> crlf
*> fmap fromList (part `sepBy1` crlf)
<* string "--" <* takeTillEnd
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
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
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
headerText :: (HasHeaders a) => CharsetLookup -> CI B.ByteString -> Lens' a (Maybe T.Text)
headerText charsets k =
headers . at k . iso (fmap (decodeEncodedWords charsets)) (fmap encodeEncodedWords)
headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)
headerSubject charsets = headerText charsets "Subject"
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)
createMultipartMixedMessage
:: B.ByteString
-> NonEmpty MIMEMessage
-> MIMEMessage
createMultipartMixedMessage b attachments' =
let hdrs = mempty &
set contentType (contentTypeMultipartMixed b)
in Message hdrs (Multipart attachments')
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)
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 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 :: MIMEMessage -> MIMEMessage
encapsulate = Message hdrs . Encapsulated
where
hdrs = mempty & set contentType "message/rfc822"