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

{- |

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
  , charsetDecoded'

  -- ** Header processing
  , decodeEncodedWords

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

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

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

  -- ** 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.Either (fromRight)
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty, fromList, intersperse)
import Data.Maybe (fromMaybe, catMaybes)
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 (MIME -> MIME -> Bool
(MIME -> MIME -> Bool) -> (MIME -> MIME -> Bool) -> Eq MIME
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MIME -> MIME -> Bool
$c/= :: MIME -> MIME -> Bool
== :: MIME -> MIME -> Bool
$c== :: MIME -> MIME -> Bool
Eq, Int -> MIME -> ShowS
[MIME] -> ShowS
MIME -> String
(Int -> MIME -> ShowS)
-> (MIME -> String) -> ([MIME] -> ShowS) -> Show MIME
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MIME] -> ShowS
$cshowList :: [MIME] -> ShowS
show :: MIME -> String
$cshow :: MIME -> String
showsPrec :: Int -> MIME -> ShowS
$cshowsPrec :: Int -> MIME -> ShowS
Show)

-- | Ignores the presence/absense of @MIME-Version@ header
instance EqMessage MIME where
  Message Headers
h1 MIME
b1 eqMessage :: Message s MIME -> Message s MIME -> Bool
`eqMessage` Message Headers
h2 MIME
b2 =
    Headers -> Headers
stripVer Headers
h1 Headers -> Headers -> Bool
forall a. Eq a => a -> a -> Bool
== Headers -> Headers
stripVer Headers
h2 Bool -> Bool -> Bool
&& MIME
b1 MIME -> MIME -> Bool
forall a. Eq a => a -> a -> Bool
== MIME
b2
    where
    stripVer :: Headers -> Headers
stripVer = ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
-> Maybe ByteString -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Headers -> Identity Headers) -> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> Identity Headers) -> Headers -> Identity Headers)
-> ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
-> ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Headers
"MIME-Version") Maybe ByteString
forall a. Maybe a
Nothing

-- | Get all leaf entities from the MIME message.
-- Entities that failed to parse are skipped.
--
entities :: Traversal' MIMEMessage WireEntity
entities :: (WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage
entities WireEntity -> f WireEntity
f (Message Headers
h MIME
a) = case MIME
a of
  Part ByteString
b ->
    (\(Message Headers
h' ByteString
b') -> Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
h' (ByteString -> MIME
Part ByteString
b')) (WireEntity -> MIMEMessage) -> f WireEntity -> f MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WireEntity -> f WireEntity
f (Headers -> ByteString -> WireEntity
forall s a. Headers -> a -> Message s a
Message Headers
h ByteString
b)
  Encapsulated MIMEMessage
msg -> Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
h (MIME -> MIMEMessage)
-> (MIMEMessage -> MIME) -> MIMEMessage -> MIMEMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MIMEMessage -> MIME
Encapsulated (MIMEMessage -> MIMEMessage) -> f MIMEMessage -> f MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage
Traversal' MIMEMessage WireEntity
entities WireEntity -> f WireEntity
f MIMEMessage
msg
  Multipart NonEmpty MIMEMessage
bs ->
    Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
h (MIME -> MIMEMessage)
-> (NonEmpty MIMEMessage -> MIME)
-> NonEmpty MIMEMessage
-> MIMEMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty MIMEMessage -> MIME
Multipart (NonEmpty MIMEMessage -> MIMEMessage)
-> f (NonEmpty MIMEMessage) -> f MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (f MIMEMessage) -> f (NonEmpty MIMEMessage)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage
Traversal' MIMEMessage WireEntity
entities WireEntity -> f WireEntity
f (MIMEMessage -> f MIMEMessage)
-> NonEmpty MIMEMessage -> NonEmpty (f MIMEMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty MIMEMessage
bs)
  FailedParse MIMEParseError
_ ByteString
_ -> MIMEMessage -> f MIMEMessage
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
h MIME
a)

-- | Leaf entities with @Content-Disposition: attachment@
attachments :: Traversal' MIMEMessage WireEntity
attachments :: (WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage
attachments = (WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage
Traversal' MIMEMessage WireEntity
entities ((WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage)
-> ((WireEntity -> f WireEntity) -> WireEntity -> f WireEntity)
-> (WireEntity -> f WireEntity)
-> MIMEMessage
-> f MIMEMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WireEntity -> Bool)
-> (WireEntity -> f WireEntity) -> WireEntity -> f WireEntity
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered WireEntity -> Bool
forall a. HasHeaders a => a -> Bool
isAttachment

-- | MIMEMessage content disposition is an 'Attachment'
isAttachment :: HasHeaders a => a -> Bool
isAttachment :: a -> Bool
isAttachment = Getting Any a DispositionType -> a -> Bool
forall s a. Getting Any s a -> s -> Bool
has ((Maybe ContentDisposition -> Const Any (Maybe ContentDisposition))
-> a -> Const Any a
forall a. HasHeaders a => Lens' a (Maybe ContentDisposition)
contentDisposition ((Maybe ContentDisposition -> Const Any (Maybe ContentDisposition))
 -> a -> Const Any a)
-> ((DispositionType -> Const Any DispositionType)
    -> Maybe ContentDisposition
    -> Const Any (Maybe ContentDisposition))
-> Getting Any a DispositionType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentDisposition -> Const Any ContentDisposition)
-> Maybe ContentDisposition -> Const Any (Maybe ContentDisposition)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ContentDisposition -> Const Any ContentDisposition)
 -> Maybe ContentDisposition
 -> Const Any (Maybe ContentDisposition))
-> ((DispositionType -> Const Any DispositionType)
    -> ContentDisposition -> Const Any ContentDisposition)
-> (DispositionType -> Const Any DispositionType)
-> Maybe ContentDisposition
-> Const Any (Maybe ContentDisposition)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DispositionType -> Const Any DispositionType)
-> ContentDisposition -> Const Any ContentDisposition
Lens' ContentDisposition DispositionType
dispositionType ((DispositionType -> Const Any DispositionType)
 -> ContentDisposition -> Const Any ContentDisposition)
-> ((DispositionType -> Const Any DispositionType)
    -> DispositionType -> Const Any DispositionType)
-> (DispositionType -> Const Any DispositionType)
-> ContentDisposition
-> Const Any ContentDisposition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DispositionType -> Bool)
-> (DispositionType -> Const Any DispositionType)
-> DispositionType
-> Const Any DispositionType
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (DispositionType -> DispositionType -> Bool
forall a. Eq a => a -> a -> Bool
== DispositionType
Attachment))

contentTransferEncoding
  :: (Profunctor p, Contravariant f) => Optic' p f Headers TransferEncodingName
contentTransferEncoding :: Optic' p f Headers TransferEncodingName
contentTransferEncoding = (Headers -> TransferEncodingName)
-> Optic' p f Headers TransferEncodingName
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Headers -> TransferEncodingName)
 -> Optic' p f Headers TransferEncodingName)
-> (Headers -> TransferEncodingName)
-> Optic' p f Headers TransferEncodingName
forall a b. (a -> b) -> a -> b
$
  TransferEncodingName
-> Maybe TransferEncodingName -> TransferEncodingName
forall a. a -> Maybe a -> a
fromMaybe TransferEncodingName
"7bit"
  (Maybe TransferEncodingName -> TransferEncodingName)
-> (Headers -> Maybe TransferEncodingName)
-> Headers
-> TransferEncodingName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First TransferEncodingName) Headers TransferEncodingName
-> Headers -> Maybe TransferEncodingName
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' Headers ByteString
forall a.
HasHeaders a =>
TransferEncodingName -> Traversal' a ByteString
header TransferEncodingName
"content-transfer-encoding" ((ByteString -> Const (First TransferEncodingName) ByteString)
 -> Headers -> Const (First TransferEncodingName) Headers)
-> ((TransferEncodingName
     -> Const (First TransferEncodingName) TransferEncodingName)
    -> ByteString -> Const (First TransferEncodingName) ByteString)
-> Getting
     (First TransferEncodingName) Headers TransferEncodingName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransferEncodingName
 -> Const (First TransferEncodingName) TransferEncodingName)
-> ByteString -> Const (First TransferEncodingName) ByteString
forall s. FoldCase s => Iso' s (CI s)
caseInsensitive)

instance HasTransferEncoding WireEntity where
  type TransferDecoded WireEntity = ByteEntity
  transferEncodingName :: (TransferEncodingName -> f TransferEncodingName)
-> WireEntity -> f WireEntity
transferEncodingName = (Headers -> f Headers) -> WireEntity -> f WireEntity
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> WireEntity -> f WireEntity)
-> ((TransferEncodingName -> f TransferEncodingName)
    -> Headers -> f Headers)
-> (TransferEncodingName -> f TransferEncodingName)
-> WireEntity
-> f WireEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransferEncodingName -> f TransferEncodingName)
-> Headers -> f Headers
forall (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Contravariant f) =>
Optic' p f Headers TransferEncodingName
contentTransferEncoding
  transferEncodedData :: (ByteString -> f ByteString) -> WireEntity -> f WireEntity
transferEncodedData = (ByteString -> f ByteString) -> WireEntity -> f WireEntity
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body
  transferDecoded :: Optic' p f WireEntity (Either e (TransferDecoded WireEntity))
transferDecoded = (WireEntity -> Either e (Message EncStateByte ByteString))
-> Optic'
     p f WireEntity (Either e (Message EncStateByte ByteString))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((WireEntity -> Either e (Message EncStateByte ByteString))
 -> Optic'
      p f WireEntity (Either e (Message EncStateByte ByteString)))
-> (WireEntity -> Either e (Message EncStateByte ByteString))
-> Optic'
     p f WireEntity (Either e (Message EncStateByte ByteString))
forall a b. (a -> b) -> a -> b
$ \WireEntity
a -> (\ByteString
t -> ASetter
  WireEntity (Message EncStateByte ByteString) ByteString ByteString
-> ByteString -> WireEntity -> Message EncStateByte ByteString
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  WireEntity (Message EncStateByte ByteString) ByteString ByteString
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body ByteString
t WireEntity
a) (ByteString -> Message EncStateByte ByteString)
-> Either e ByteString
-> Either e (Message EncStateByte ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Either e ByteString) WireEntity (Either e ByteString)
-> WireEntity -> Either e ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Either e ByteString) WireEntity (Either e ByteString)
forall a e (p :: * -> * -> *) (f :: * -> *).
(HasTransferEncoding a, AsTransferEncodingError e, Profunctor p,
 Contravariant f) =>
Optic' p f a (Either e ByteString)
transferDecodedBytes WireEntity
a

  transferEncode :: TransferDecoded WireEntity -> WireEntity
transferEncode (Message h s) =
    let
      (TransferEncodingName
cteName, TransferEncoding
cte) = ByteString -> (TransferEncodingName, TransferEncoding)
chooseTransferEncoding ByteString
s
      s' :: ByteString
s' = AReview ByteString ByteString -> ByteString -> ByteString
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review (TransferEncoding
-> Prism ByteString ByteString ByteString ByteString
forall s t a b. APrism s t a b -> Prism s t a b
clonePrism TransferEncoding
cte) ByteString
s
      cteName' :: ByteString
cteName' = TransferEncodingName -> ByteString
forall s. CI s -> s
CI.original TransferEncodingName
cteName
      h' :: Headers
h' = ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
-> Maybe ByteString -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Headers -> Identity Headers) -> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> Identity Headers) -> Headers -> Identity Headers)
-> ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
-> ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Headers
"Content-Transfer-Encoding") (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
cteName') Headers
h
    in
      Headers -> ByteString -> WireEntity
forall s a. Headers -> a -> Message s a
Message Headers
h' ByteString
s'

caseInsensitive :: CI.FoldCase s => Iso' s (CI s)
caseInsensitive :: Iso' s (CI s)
caseInsensitive = (s -> CI s) -> (CI s -> s) -> Iso' s (CI s)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso s -> CI s
forall s. FoldCase s => s -> CI s
CI.mk CI s -> s
forall s. CI s -> s
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 (Int -> ContentType -> ShowS
[ContentType] -> ShowS
ContentType -> String
(Int -> ContentType -> ShowS)
-> (ContentType -> String)
-> ([ContentType] -> ShowS)
-> Show ContentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentType] -> ShowS
$cshowList :: [ContentType] -> ShowS
show :: ContentType -> String
$cshow :: ContentType -> String
showsPrec :: Int -> ContentType -> ShowS
$cshowsPrec :: Int -> ContentType -> ShowS
Show, (forall x. ContentType -> Rep ContentType x)
-> (forall x. Rep ContentType x -> ContentType)
-> Generic ContentType
forall x. Rep ContentType x -> ContentType
forall x. ContentType -> Rep ContentType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ContentType x -> ContentType
$cfrom :: forall x. ContentType -> Rep ContentType x
Generic, ContentType -> ()
(ContentType -> ()) -> NFData ContentType
forall a. (a -> ()) -> NFData a
rnf :: ContentType -> ()
$crnf :: ContentType -> ()
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 TransferEncodingName
a TransferEncodingName
b Parameters
c == :: ContentType -> ContentType -> Bool
== ContentType TransferEncodingName
a' TransferEncodingName
b' Parameters
c' = TransferEncodingName
a TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
a' Bool -> Bool -> Bool
&& TransferEncodingName
b TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
b' Bool -> Bool -> Bool
&& Parameters
c Parameters -> Parameters -> Bool
forall a. Eq a => a -> a -> Bool
== Parameters
c'

-- | __NON-TOTAL__ parses the Content-Type (including parameters)
-- and throws an error if the parse fails
--
instance IsString ContentType where
  fromString :: String -> ContentType
fromString = (String -> ContentType)
-> (ContentType -> ContentType)
-> Either String ContentType
-> ContentType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ContentType
forall a. String -> a
err ContentType -> ContentType
forall a. a -> a
id (Either String ContentType -> ContentType)
-> (String -> Either String ContentType) -> String -> ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ContentType -> ByteString -> Either String ContentType
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser ContentType
parseContentType (ByteString -> Either String ContentType)
-> (String -> ByteString) -> String -> Either String ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C8.pack
    where
    err :: String -> a
err String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"failed to parse Content-Type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
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 :: TransferEncodingName
-> Maybe TransferEncodingName -> ContentType -> Bool
matchContentType TransferEncodingName
wantType Maybe TransferEncodingName
wantSubtype (ContentType TransferEncodingName
gotType TransferEncodingName
gotSubtype Parameters
_) =
  TransferEncodingName
wantType TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
gotType Bool -> Bool -> Bool
&& Bool
-> (TransferEncodingName -> Bool)
-> Maybe TransferEncodingName
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
gotSubtype) Maybe TransferEncodingName
wantSubtype

renderContentType :: ContentType -> B.ByteString
renderContentType :: ContentType -> ByteString
renderContentType (ContentType TransferEncodingName
typ TransferEncodingName
sub Parameters
params) =
  TransferEncodingName -> ByteString
forall s. CI s -> s
CI.original TransferEncodingName
typ ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> TransferEncodingName -> ByteString
forall s. CI s -> s
CI.original TransferEncodingName
sub ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Parameters -> ByteString
printParameters Parameters
params

printParameters :: Parameters -> B.ByteString
printParameters :: Parameters -> ByteString
printParameters (Parameters [(TransferEncodingName, ByteString)]
xs) =
  ((TransferEncodingName, ByteString) -> ByteString)
-> [(TransferEncodingName, ByteString)] -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TransferEncodingName
k,ByteString
v) -> ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> TransferEncodingName -> ByteString
forall s. CI s -> s
CI.original TransferEncodingName
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v) [(TransferEncodingName, ByteString)]
xs

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

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

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

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

-- | Rendered content type field value for displaying
showContentType :: ContentType -> T.Text
showContentType :: ContentType -> Text
showContentType = ByteString -> Text
decodeLenient (ByteString -> Text)
-> (ContentType -> ByteString) -> ContentType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentType -> ByteString
renderContentType

instance HasParameters ContentType where
  parameters :: (Parameters -> f Parameters) -> ContentType -> f ContentType
parameters = (Parameters -> f Parameters) -> ContentType -> f ContentType
Lens' ContentType Parameters
ctParameters

-- | Parser for Content-Type header
parseContentType :: Parser ContentType
parseContentType :: Parser ContentType
parseContentType = do
  TransferEncodingName
typ <- Parser ByteString -> Parser TransferEncodingName
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token
  Word8
_ <- Char -> Parser Word8
char8 Char
'/'
  TransferEncodingName
subtype <- Parser ByteString -> Parser TransferEncodingName
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token
  [(TransferEncodingName, ByteString)]
params <- Parser [(TransferEncodingName, ByteString)]
parseParameters
  if TransferEncodingName
typ TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
"multipart" Bool -> Bool -> Bool
&& TransferEncodingName
"boundary" TransferEncodingName -> [TransferEncodingName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ((TransferEncodingName, ByteString) -> TransferEncodingName)
-> [(TransferEncodingName, ByteString)] -> [TransferEncodingName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TransferEncodingName, ByteString) -> TransferEncodingName
forall a b. (a, b) -> a
fst [(TransferEncodingName, ByteString)]
params
    then
      -- https://tools.ietf.org/html/rfc2046#section-5.1.1
      String -> Parser ContentType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"\"boundary\" parameter is required for multipart content type"
    else ContentType -> Parser ContentType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContentType -> Parser ContentType)
-> ContentType -> Parser ContentType
forall a b. (a -> b) -> a -> b
$ TransferEncodingName
-> TransferEncodingName -> Parameters -> ContentType
ContentType TransferEncodingName
typ TransferEncodingName
subtype ([(TransferEncodingName, ByteString)] -> Parameters
Parameters [(TransferEncodingName, ByteString)]
params)

parseParameters :: Parser [(CI B.ByteString, B.ByteString)]
parseParameters :: Parser [(TransferEncodingName, ByteString)]
parseParameters = Parser ByteString (TransferEncodingName, ByteString)
-> Parser [(TransferEncodingName, ByteString)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Word8
char8 Char
';' Parser Word8 -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ()
skipWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32 {-SP-}) Parser ByteString ()
-> Parser ByteString (TransferEncodingName, ByteString)
-> Parser ByteString (TransferEncodingName, ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (TransferEncodingName, ByteString)
param)
  where
    param :: Parser ByteString (TransferEncodingName, ByteString)
param = (,) (TransferEncodingName
 -> ByteString -> (TransferEncodingName, ByteString))
-> Parser TransferEncodingName
-> Parser
     ByteString (ByteString -> (TransferEncodingName, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString -> Parser TransferEncodingName
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token Parser
  ByteString (ByteString -> (TransferEncodingName, ByteString))
-> Parser Word8
-> Parser
     ByteString (ByteString -> (TransferEncodingName, ByteString))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Word8
char8 Char
'=' Parser
  ByteString (ByteString -> (TransferEncodingName, ByteString))
-> Parser ByteString
-> Parser ByteString (TransferEncodingName, ByteString)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
val
    val :: Parser ByteString
val = Parser ByteString
token Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
quotedString

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

-- | RFC 2046 §4.1.2. defines the default character set to be US-ASCII.
--
instance HasCharset ByteEntity where
  type Decoded ByteEntity = TextEntity
  charsetName :: (Maybe TransferEncodingName -> f (Maybe TransferEncodingName))
-> Message EncStateByte ByteString
-> f (Message EncStateByte ByteString)
charsetName = (Message EncStateByte ByteString -> Maybe TransferEncodingName)
-> (Maybe TransferEncodingName -> f (Maybe TransferEncodingName))
-> Message EncStateByte ByteString
-> f (Message EncStateByte ByteString)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Message EncStateByte ByteString -> Maybe TransferEncodingName)
 -> (Maybe TransferEncodingName -> f (Maybe TransferEncodingName))
 -> Message EncStateByte ByteString
 -> f (Message EncStateByte ByteString))
-> (Message EncStateByte ByteString -> Maybe TransferEncodingName)
-> (Maybe TransferEncodingName -> f (Maybe TransferEncodingName))
-> Message EncStateByte ByteString
-> f (Message EncStateByte ByteString)
forall a b. (a -> b) -> a -> b
$ \Message EncStateByte ByteString
ent ->
    let
      (ContentType TransferEncodingName
typ TransferEncodingName
sub Parameters
params) = Getting ContentType (Message EncStateByte ByteString) ContentType
-> Message EncStateByte ByteString -> ContentType
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Headers -> Const ContentType Headers)
-> Message EncStateByte ByteString
-> Const ContentType (Message EncStateByte ByteString)
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> Const ContentType Headers)
 -> Message EncStateByte ByteString
 -> Const ContentType (Message EncStateByte ByteString))
-> ((ContentType -> Const ContentType ContentType)
    -> Headers -> Const ContentType Headers)
-> Getting
     ContentType (Message EncStateByte ByteString) ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentType -> Const ContentType ContentType)
-> Headers -> Const ContentType Headers
forall a. HasHeaders a => Lens' a ContentType
contentType) Message EncStateByte ByteString
ent
      source :: TransferEncodingName -> EntityCharsetSource
source = EntityCharsetSource
-> Maybe EntityCharsetSource -> EntityCharsetSource
forall a. a -> Maybe a -> a
fromMaybe (Maybe TransferEncodingName -> EntityCharsetSource
InParameter (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii")) (Maybe EntityCharsetSource -> EntityCharsetSource)
-> (TransferEncodingName -> Maybe EntityCharsetSource)
-> TransferEncodingName
-> EntityCharsetSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransferEncodingName
-> [(TransferEncodingName, EntityCharsetSource)]
-> Maybe EntityCharsetSource
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(TransferEncodingName, EntityCharsetSource)]
textCharsetSources)
      l :: (TransferEncodingName
 -> Const (First TransferEncodingName) TransferEncodingName)
-> Parameters -> Const (First TransferEncodingName) Parameters
l = TransferEncodingName -> Traversal' Parameters ByteString
forall a.
HasParameters a =>
TransferEncodingName -> Traversal' a ByteString
rawParameter TransferEncodingName
"charset" ((ByteString -> Const (First TransferEncodingName) ByteString)
 -> Parameters -> Const (First TransferEncodingName) Parameters)
-> ((TransferEncodingName
     -> Const (First TransferEncodingName) TransferEncodingName)
    -> ByteString -> Const (First TransferEncodingName) ByteString)
-> (TransferEncodingName
    -> Const (First TransferEncodingName) TransferEncodingName)
-> Parameters
-> Const (First TransferEncodingName) Parameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransferEncodingName
 -> Const (First TransferEncodingName) TransferEncodingName)
-> ByteString -> Const (First TransferEncodingName) ByteString
forall s. FoldCase s => Iso' s (CI s)
caseInsensitive
    in
      if TransferEncodingName
typ TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
"text"
      then case TransferEncodingName -> EntityCharsetSource
source TransferEncodingName
sub of
        InBand ByteString -> Maybe TransferEncodingName
f -> ByteString -> Maybe TransferEncodingName
f (Getting ByteString (Message EncStateByte ByteString) ByteString
-> Message EncStateByte ByteString -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString (Message EncStateByte ByteString) ByteString
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body Message EncStateByte ByteString
ent)
        InParameter Maybe TransferEncodingName
def -> ((TransferEncodingName
  -> Const (First TransferEncodingName) TransferEncodingName)
 -> Parameters -> Const (First TransferEncodingName) Parameters)
-> Parameters -> Maybe TransferEncodingName
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName
 -> Const (First TransferEncodingName) TransferEncodingName)
-> Parameters -> Const (First TransferEncodingName) Parameters
l Parameters
params Maybe TransferEncodingName
-> Maybe TransferEncodingName -> Maybe TransferEncodingName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TransferEncodingName
def
        InBandOrParameter ByteString -> Maybe TransferEncodingName
f Maybe TransferEncodingName
def -> ByteString -> Maybe TransferEncodingName
f (Getting ByteString (Message EncStateByte ByteString) ByteString
-> Message EncStateByte ByteString -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString (Message EncStateByte ByteString) ByteString
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body Message EncStateByte ByteString
ent) Maybe TransferEncodingName
-> Maybe TransferEncodingName -> Maybe TransferEncodingName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((TransferEncodingName
  -> Const (First TransferEncodingName) TransferEncodingName)
 -> Parameters -> Const (First TransferEncodingName) Parameters)
-> Parameters -> Maybe TransferEncodingName
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName
 -> Const (First TransferEncodingName) TransferEncodingName)
-> Parameters -> Const (First TransferEncodingName) Parameters
l Parameters
params Maybe TransferEncodingName
-> Maybe TransferEncodingName -> Maybe TransferEncodingName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TransferEncodingName
def
      else
        ((TransferEncodingName
  -> Const (First TransferEncodingName) TransferEncodingName)
 -> Parameters -> Const (First TransferEncodingName) Parameters)
-> Parameters -> Maybe TransferEncodingName
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName
 -> Const (First TransferEncodingName) TransferEncodingName)
-> Parameters -> Const (First TransferEncodingName) Parameters
l Parameters
params Maybe TransferEncodingName
-> Maybe TransferEncodingName -> Maybe TransferEncodingName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii"
  charsetData :: (ByteString -> f ByteString)
-> Message EncStateByte ByteString
-> f (Message EncStateByte ByteString)
charsetData = (ByteString -> f ByteString)
-> Message EncStateByte ByteString
-> f (Message EncStateByte ByteString)
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body -- XXX: do we need to drop the BOM / encoding decl?
  charsetDecoded :: CharsetLookup
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Profunctor p, Contravariant f) =>
   Optic'
     p
     f
     (Message EncStateByte ByteString)
     (Either e (Decoded (Message EncStateByte ByteString)))
charsetDecoded CharsetLookup
m = (Message EncStateByte ByteString -> Either e (Message () Text))
-> Optic'
     p f (Message EncStateByte ByteString) (Either e (Message () Text))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Message EncStateByte ByteString -> Either e (Message () Text))
 -> Optic'
      p f (Message EncStateByte ByteString) (Either e (Message () Text)))
-> (Message EncStateByte ByteString -> Either e (Message () Text))
-> Optic'
     p f (Message EncStateByte ByteString) (Either e (Message () Text))
forall a b. (a -> b) -> a -> b
$ \Message EncStateByte ByteString
a -> (\Text
t -> ASetter
  (Message EncStateByte ByteString) (Message () Text) ByteString Text
-> Text -> Message EncStateByte ByteString -> Message () Text
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Message EncStateByte ByteString) (Message () Text) ByteString Text
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body Text
t Message EncStateByte ByteString
a) (Text -> Message () Text)
-> Either e Text -> Either e (Message () Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Either e Text) (Message EncStateByte ByteString) (Either e Text)
-> Message EncStateByte ByteString -> Either e Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup
-> Getting
     (Either e Text) (Message EncStateByte ByteString) (Either e Text)
forall a e (p :: * -> * -> *) (f :: * -> *).
(HasCharset a, AsCharsetError e, Profunctor p, Contravariant f) =>
CharsetLookup -> Optic' p f a (Either e Text)
charsetText CharsetLookup
m) Message EncStateByte ByteString
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 :: Decoded (Message EncStateByte ByteString)
-> Message EncStateByte ByteString
charsetEncode (Message h a) =
    let
      b :: ByteString
b = Text -> ByteString
T.encodeUtf8 Text
a
      charset :: EncodedParameterValue
charset = if (Word8 -> Bool) -> ByteString -> Bool
B.all (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80) ByteString
b then EncodedParameterValue
"us-ascii" else EncodedParameterValue
"utf-8"
    in Headers -> ByteString -> Message EncStateByte ByteString
forall s a. Headers -> a -> Message s a
Message (ASetter
  Headers
  Headers
  (Maybe EncodedParameterValue)
  (Maybe EncodedParameterValue)
-> Maybe EncodedParameterValue -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ((ContentType -> Identity ContentType)
-> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a ContentType
contentType ((ContentType -> Identity ContentType)
 -> Headers -> Identity Headers)
-> ((Maybe EncodedParameterValue
     -> Identity (Maybe EncodedParameterValue))
    -> ContentType -> Identity ContentType)
-> ASetter
     Headers
     Headers
     (Maybe EncodedParameterValue)
     (Maybe EncodedParameterValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferEncodingName
-> Lens' ContentType (Maybe EncodedParameterValue)
forall a.
HasParameters a =>
TransferEncodingName -> Lens' a (Maybe EncodedParameterValue)
parameter TransferEncodingName
"charset") (EncodedParameterValue -> Maybe EncodedParameterValue
forall a. a -> Maybe a
Just EncodedParameterValue
charset) Headers
h) ByteString
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 :: [(TransferEncodingName, EntityCharsetSource)]
textCharsetSources =
  [ (TransferEncodingName
"plain", Maybe TransferEncodingName -> EntityCharsetSource
InParameter (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii"))
  , (TransferEncodingName
"csv", Maybe TransferEncodingName -> EntityCharsetSource
InParameter (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"utf-8"))
  , (TransferEncodingName
"rtf", (ByteString -> Maybe TransferEncodingName) -> EntityCharsetSource
InBand (Maybe TransferEncodingName
-> ByteString -> Maybe TransferEncodingName
forall a b. a -> b -> a
const (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii" {- TODO -})))

  -- https://tools.ietf.org/html/rfc2854
  -- The default is ambiguous; using us-ascii for now
  , (TransferEncodingName
"html", (ByteString -> Maybe TransferEncodingName)
-> Maybe TransferEncodingName -> EntityCharsetSource
InBandOrParameter (Maybe TransferEncodingName
-> ByteString -> Maybe TransferEncodingName
forall a b. a -> b -> a
const Maybe TransferEncodingName
forall a. Maybe a
Nothing {-TODO-}) (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii"))

  -- https://tools.ietf.org/html/rfc7763
  , (TransferEncodingName
"markdown", Maybe TransferEncodingName -> EntityCharsetSource
InParameter Maybe TransferEncodingName
forall a. Maybe a
Nothing)

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

-- | @text/plain; charset=us-ascii@
defaultContentType :: ContentType
defaultContentType :: ContentType
defaultContentType =
  ASetter
  ContentType
  ContentType
  [(TransferEncodingName, ByteString)]
  [(TransferEncodingName, ByteString)]
-> ([(TransferEncodingName, ByteString)]
    -> [(TransferEncodingName, ByteString)])
-> ContentType
-> ContentType
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  ContentType
  ContentType
  [(TransferEncodingName, ByteString)]
  [(TransferEncodingName, ByteString)]
forall a.
HasParameters a =>
Lens' a [(TransferEncodingName, ByteString)]
parameterList ((TransferEncodingName
"charset", ByteString
"us-ascii")(TransferEncodingName, ByteString)
-> [(TransferEncodingName, ByteString)]
-> [(TransferEncodingName, ByteString)]
forall a. a -> [a] -> [a]
:) ContentType
contentTypeTextPlain

-- | @text/plain@
contentTypeTextPlain :: ContentType
contentTypeTextPlain :: ContentType
contentTypeTextPlain = TransferEncodingName
-> TransferEncodingName -> Parameters -> ContentType
ContentType TransferEncodingName
"text" TransferEncodingName
"plain" Parameters
forall a. Monoid a => a
mempty

-- | @application/octet-stream@
contentTypeApplicationOctetStream :: ContentType
contentTypeApplicationOctetStream :: ContentType
contentTypeApplicationOctetStream =
  TransferEncodingName
-> TransferEncodingName -> Parameters -> ContentType
ContentType TransferEncodingName
"application" TransferEncodingName
"octet-stream" Parameters
forall a. Monoid a => a
mempty

-- | @multipart/mixed; boundary=asdf@
contentTypeMultipartMixed :: B.ByteString -> ContentType
contentTypeMultipartMixed :: ByteString -> ContentType
contentTypeMultipartMixed ByteString
boundary =
  ((Maybe EncodedParameterValue
  -> Identity (Maybe EncodedParameterValue))
 -> ContentType -> Identity ContentType)
-> Maybe EncodedParameterValue -> ContentType -> ContentType
forall s t a b. ASetter s t a b -> b -> s -> t
set (TransferEncodingName
-> Lens' ContentType (Maybe EncodedParameterValue)
forall a.
HasParameters a =>
TransferEncodingName -> Lens' a (Maybe EncodedParameterValue)
parameter TransferEncodingName
"boundary") (EncodedParameterValue -> Maybe EncodedParameterValue
forall a. a -> Maybe a
Just (Maybe TransferEncodingName
-> Maybe TransferEncodingName
-> ByteString
-> EncodedParameterValue
forall cs a.
Maybe cs -> Maybe TransferEncodingName -> a -> ParameterValue cs a
ParameterValue Maybe TransferEncodingName
forall a. Maybe a
Nothing Maybe TransferEncodingName
forall a. Maybe a
Nothing ByteString
boundary))
  (ContentType -> ContentType) -> ContentType -> ContentType
forall a b. (a -> b) -> a -> b
$ TransferEncodingName
-> TransferEncodingName -> Parameters -> ContentType
ContentType TransferEncodingName
"multipart" TransferEncodingName
"mixed" Parameters
forall a. Monoid a => a
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 :: Lens' a ContentType
contentType = (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> ((ContentType -> f ContentType) -> Headers -> f Headers)
-> (ContentType -> f ContentType)
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Headers -> ContentType)
-> (Headers -> ContentType -> Headers)
-> Lens Headers Headers ContentType ContentType
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Headers -> ContentType
sa Headers -> ContentType -> Headers
forall t.
(At t, IsString (Index t), IxValue t ~ ByteString) =>
t -> ContentType -> t
sbt where
  sa :: Headers -> ContentType
sa Headers
s = case Getting (Maybe TransferEncoding) Headers (Maybe TransferEncoding)
-> Headers -> Maybe TransferEncoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe TransferEncoding) Headers (Maybe TransferEncoding)
cte Headers
s of
    Maybe TransferEncoding
Nothing -> ContentType
contentTypeApplicationOctetStream
    Just TransferEncoding
_ ->
      ContentType -> Maybe ContentType -> ContentType
forall a. a -> Maybe a -> a
fromMaybe ContentType
defaultContentType (Maybe ContentType -> ContentType)
-> Maybe ContentType -> ContentType
forall a b. (a -> b) -> a -> b
$ Getting (First ContentType) Headers ContentType
-> Headers -> Maybe ContentType
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((ByteString -> Const (First ContentType) ByteString)
-> Headers -> Const (First ContentType) Headers
ct ((ByteString -> Const (First ContentType) ByteString)
 -> Headers -> Const (First ContentType) Headers)
-> ((ContentType -> Const (First ContentType) ContentType)
    -> ByteString -> Const (First ContentType) ByteString)
-> Getting (First ContentType) Headers ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ContentType -> Fold ByteString ContentType
forall s a. Cons s s Word8 Word8 => Parser a -> Fold s a
parsed Parser ContentType
parseContentType) Headers
s

  sbt :: t -> ContentType -> t
sbt t
s ContentType
b = ASetter t t (Maybe (IxValue t)) (Maybe ByteString)
-> Maybe ByteString -> t -> t
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index t -> Lens' t (Maybe (IxValue t))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index t
"Content-Type") (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ContentType -> ByteString
renderContentType ContentType
b)) t
s

  ct :: (ByteString -> Const (First ContentType) ByteString)
-> Headers -> Const (First ContentType) Headers
ct = TransferEncodingName -> Traversal' Headers ByteString
forall a.
HasHeaders a =>
TransferEncodingName -> Traversal' a ByteString
header TransferEncodingName
"content-type"
  cte :: Getting (Maybe TransferEncoding) Headers (Maybe TransferEncoding)
cte = Optic'
  (->) (Const (Maybe TransferEncoding)) Headers TransferEncodingName
forall (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Contravariant f) =>
Optic' p f Headers TransferEncodingName
contentTransferEncoding Optic'
  (->) (Const (Maybe TransferEncoding)) Headers TransferEncodingName
-> ((Maybe TransferEncoding
     -> Const (Maybe TransferEncoding) (Maybe TransferEncoding))
    -> TransferEncodingName
    -> Const (Maybe TransferEncoding) TransferEncodingName)
-> Getting
     (Maybe TransferEncoding) Headers (Maybe TransferEncoding)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransferEncodingName -> Maybe TransferEncoding)
-> (Maybe TransferEncoding
    -> Const (Maybe TransferEncoding) (Maybe TransferEncoding))
-> TransferEncodingName
-> Const (Maybe TransferEncoding) TransferEncodingName
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (TransferEncodingName
-> [(TransferEncodingName, TransferEncoding)]
-> Maybe TransferEncoding
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(TransferEncodingName, TransferEncoding)]
transferEncodings)

-- | Content-Disposition header (RFC 2183).
--
-- Use 'parameters' to access the parameters.
--
data ContentDisposition = ContentDisposition
  DispositionType   -- disposition
  Parameters        -- parameters
  deriving (Int -> ContentDisposition -> ShowS
[ContentDisposition] -> ShowS
ContentDisposition -> String
(Int -> ContentDisposition -> ShowS)
-> (ContentDisposition -> String)
-> ([ContentDisposition] -> ShowS)
-> Show ContentDisposition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentDisposition] -> ShowS
$cshowList :: [ContentDisposition] -> ShowS
show :: ContentDisposition -> String
$cshow :: ContentDisposition -> String
showsPrec :: Int -> ContentDisposition -> ShowS
$cshowsPrec :: Int -> ContentDisposition -> ShowS
Show, (forall x. ContentDisposition -> Rep ContentDisposition x)
-> (forall x. Rep ContentDisposition x -> ContentDisposition)
-> Generic ContentDisposition
forall x. Rep ContentDisposition x -> ContentDisposition
forall x. ContentDisposition -> Rep ContentDisposition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ContentDisposition x -> ContentDisposition
$cfrom :: forall x. ContentDisposition -> Rep ContentDisposition x
Generic, ContentDisposition -> ()
(ContentDisposition -> ()) -> NFData ContentDisposition
forall a. (a -> ()) -> NFData a
rnf :: ContentDisposition -> ()
$crnf :: ContentDisposition -> ()
NFData)

data DispositionType = Inline | Attachment
  deriving (DispositionType -> DispositionType -> Bool
(DispositionType -> DispositionType -> Bool)
-> (DispositionType -> DispositionType -> Bool)
-> Eq DispositionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DispositionType -> DispositionType -> Bool
$c/= :: DispositionType -> DispositionType -> Bool
== :: DispositionType -> DispositionType -> Bool
$c== :: DispositionType -> DispositionType -> Bool
Eq, Int -> DispositionType -> ShowS
[DispositionType] -> ShowS
DispositionType -> String
(Int -> DispositionType -> ShowS)
-> (DispositionType -> String)
-> ([DispositionType] -> ShowS)
-> Show DispositionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DispositionType] -> ShowS
$cshowList :: [DispositionType] -> ShowS
show :: DispositionType -> String
$cshow :: DispositionType -> String
showsPrec :: Int -> DispositionType -> ShowS
$cshowsPrec :: Int -> DispositionType -> ShowS
Show, (forall x. DispositionType -> Rep DispositionType x)
-> (forall x. Rep DispositionType x -> DispositionType)
-> Generic DispositionType
forall x. Rep DispositionType x -> DispositionType
forall x. DispositionType -> Rep DispositionType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DispositionType x -> DispositionType
$cfrom :: forall x. DispositionType -> Rep DispositionType x
Generic, DispositionType -> ()
(DispositionType -> ()) -> NFData DispositionType
forall a. (a -> ()) -> NFData a
rnf :: DispositionType -> ()
$crnf :: DispositionType -> ()
NFData)

dispositionType :: Lens' ContentDisposition DispositionType
dispositionType :: (DispositionType -> f DispositionType)
-> ContentDisposition -> f ContentDisposition
dispositionType DispositionType -> f DispositionType
f (ContentDisposition DispositionType
a Parameters
b) =
  (DispositionType -> ContentDisposition)
-> f DispositionType -> f ContentDisposition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DispositionType
a' -> DispositionType -> Parameters -> ContentDisposition
ContentDisposition DispositionType
a' Parameters
b) (DispositionType -> f DispositionType
f DispositionType
a)
{-# ANN dispositionType ("HLint: ignore Avoid lambda using `infix`" :: String) #-}

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

instance HasParameters ContentDisposition where
  parameters :: (Parameters -> f Parameters)
-> ContentDisposition -> f ContentDisposition
parameters = (Parameters -> f Parameters)
-> ContentDisposition -> f ContentDisposition
Lens' ContentDisposition 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 :: Parser ContentDisposition
parseContentDisposition = DispositionType -> Parameters -> ContentDisposition
ContentDisposition
  (DispositionType -> Parameters -> ContentDisposition)
-> Parser ByteString DispositionType
-> Parser ByteString (Parameters -> ContentDisposition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TransferEncodingName -> DispositionType
forall a. (Eq a, IsString a) => a -> DispositionType
mapDispType (TransferEncodingName -> DispositionType)
-> Parser TransferEncodingName -> Parser ByteString DispositionType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString -> Parser TransferEncodingName
forall s. FoldCase s => Parser s -> Parser (CI s)
ci Parser ByteString
token)
  Parser ByteString (Parameters -> ContentDisposition)
-> Parser ByteString Parameters -> Parser ContentDisposition
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(TransferEncodingName, ByteString)] -> Parameters
Parameters ([(TransferEncodingName, ByteString)] -> Parameters)
-> Parser [(TransferEncodingName, ByteString)]
-> Parser ByteString Parameters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [(TransferEncodingName, ByteString)]
parseParameters)
  where
    mapDispType :: a -> DispositionType
mapDispType a
s
      | a
s a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"inline" = DispositionType
Inline
      | Bool
otherwise = DispositionType
Attachment

-- | Render the Content-Disposition value, including parameters.
renderContentDisposition :: ContentDisposition -> B.ByteString
renderContentDisposition :: ContentDisposition -> ByteString
renderContentDisposition (ContentDisposition DispositionType
typ Parameters
params) =
  ByteString
typStr ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Parameters -> ByteString
printParameters Parameters
params
  where
    typStr :: ByteString
typStr = case DispositionType
typ of DispositionType
Inline -> ByteString
"inline" ; DispositionType
Attachment -> ByteString
"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 :: Lens' a (Maybe ContentDisposition)
contentDisposition = (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> ((Maybe ContentDisposition -> f (Maybe ContentDisposition))
    -> Headers -> f Headers)
-> (Maybe ContentDisposition -> f (Maybe ContentDisposition))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Headers
"Content-Disposition" ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> ((Maybe ContentDisposition -> f (Maybe ContentDisposition))
    -> Maybe ByteString -> f (Maybe ByteString))
-> (Maybe ContentDisposition -> f (Maybe ContentDisposition))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> Maybe ContentDisposition)
-> (f (Maybe ContentDisposition) -> f (Maybe ByteString))
-> (Maybe ContentDisposition -> f (Maybe ContentDisposition))
-> Maybe ByteString
-> f (Maybe ByteString)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap
  (Maybe ByteString
-> (ByteString -> Maybe ContentDisposition)
-> Maybe ContentDisposition
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Maybe ContentDisposition)
-> (ContentDisposition -> Maybe ContentDisposition)
-> Either String ContentDisposition
-> Maybe ContentDisposition
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ContentDisposition -> String -> Maybe ContentDisposition
forall a b. a -> b -> a
const Maybe ContentDisposition
forall a. Maybe a
Nothing) ContentDisposition -> Maybe ContentDisposition
forall a. a -> Maybe a
Just (Either String ContentDisposition -> Maybe ContentDisposition)
-> (ByteString -> Either String ContentDisposition)
-> ByteString
-> Maybe ContentDisposition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ContentDisposition
-> ByteString -> Either String ContentDisposition
forall s a.
Cons s s Word8 Word8 =>
Parser a -> s -> Either String a
Data.RFC5322.parse Parser ContentDisposition
parseContentDisposition)
  ((Maybe ContentDisposition -> Maybe ByteString)
-> f (Maybe ContentDisposition) -> f (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe ContentDisposition -> Maybe ByteString)
 -> f (Maybe ContentDisposition) -> f (Maybe ByteString))
-> ((ContentDisposition -> ByteString)
    -> Maybe ContentDisposition -> Maybe ByteString)
-> (ContentDisposition -> ByteString)
-> f (Maybe ContentDisposition)
-> f (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentDisposition -> ByteString)
-> Maybe ContentDisposition -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ContentDisposition -> ByteString)
 -> f (Maybe ContentDisposition) -> f (Maybe ByteString))
-> (ContentDisposition -> ByteString)
-> f (Maybe ContentDisposition)
-> f (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ContentDisposition -> ByteString
renderContentDisposition)

-- | Traverse the value of the filename parameter (if present).
--
filename :: HasParameters a => CharsetLookup -> Traversal' a T.Text
filename :: CharsetLookup -> Traversal' a Text
filename CharsetLookup
m = (Maybe EncodedParameterValue -> f (Maybe EncodedParameterValue))
-> a -> f a
forall a. HasParameters a => Lens' a (Maybe EncodedParameterValue)
filenameParameter ((Maybe EncodedParameterValue -> f (Maybe EncodedParameterValue))
 -> a -> f a)
-> ((Text -> f Text)
    -> Maybe EncodedParameterValue -> f (Maybe EncodedParameterValue))
-> (Text -> f Text)
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EncodedParameterValue -> f EncodedParameterValue)
-> Maybe EncodedParameterValue -> f (Maybe EncodedParameterValue)
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed ((EncodedParameterValue -> f EncodedParameterValue)
 -> Maybe EncodedParameterValue -> f (Maybe EncodedParameterValue))
-> ((Text -> f Text)
    -> EncodedParameterValue -> f EncodedParameterValue)
-> (Text -> f Text)
-> Maybe EncodedParameterValue
-> f (Maybe EncodedParameterValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharsetLookup
-> Prism' EncodedParameterValue (Decoded EncodedParameterValue)
forall a. HasCharset a => CharsetLookup -> Prism' a (Decoded a)
charsetPrism CharsetLookup
m ((DecodedParameterValue -> f DecodedParameterValue)
 -> EncodedParameterValue -> f EncodedParameterValue)
-> ((Text -> f Text)
    -> DecodedParameterValue -> f DecodedParameterValue)
-> (Text -> f Text)
-> EncodedParameterValue
-> f EncodedParameterValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text)
-> DecodedParameterValue -> f DecodedParameterValue
forall cs a b. Lens (ParameterValue cs a) (ParameterValue cs b) a b
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 :: Lens' a (Maybe EncodedParameterValue)
filenameParameter = TransferEncodingName -> Lens' a (Maybe EncodedParameterValue)
forall a.
HasParameters a =>
TransferEncodingName -> Lens' a (Maybe EncodedParameterValue)
parameter TransferEncodingName
"filename"


-- | Get the boundary, if specified
mimeBoundary :: Traversal' ContentType B.ByteString
mimeBoundary :: (ByteString -> f ByteString) -> ContentType -> f ContentType
mimeBoundary = (Parameters -> f Parameters) -> ContentType -> f ContentType
forall a. HasParameters a => Lens' a Parameters
parameters ((Parameters -> f Parameters) -> ContentType -> f ContentType)
-> ((ByteString -> f ByteString) -> Parameters -> f Parameters)
-> (ByteString -> f ByteString)
-> ContentType
-> f ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferEncodingName -> Traversal' Parameters ByteString
forall a.
HasParameters a =>
TransferEncodingName -> Traversal' a ByteString
rawParameter TransferEncodingName
"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 :: Headers -> BodyHandler MIME
mime Headers
h
  | Getting All Headers ByteString -> Headers -> Bool
forall s a. Getting All s a -> s -> Bool
nullOf (TransferEncodingName -> Traversal' Headers ByteString
forall a.
HasHeaders a =>
TransferEncodingName -> Traversal' a ByteString
header TransferEncodingName
"MIME-Version") Headers
h = Parser MIME -> BodyHandler MIME
forall a. Parser a -> BodyHandler a
RequiredBody (ByteString -> MIME
Part (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeByteString)
  | Bool
otherwise = Parser ByteString -> Headers -> BodyHandler MIME
mime' Parser ByteString
takeByteString Headers
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' :: Parser ByteString -> Headers -> BodyHandler MIME
mime' Parser ByteString
takeTillEnd Headers
h = Parser MIME -> BodyHandler MIME
forall a. Parser a -> BodyHandler a
RequiredBody (Parser MIME -> BodyHandler MIME)
-> Parser MIME -> BodyHandler MIME
forall a b. (a -> b) -> a -> b
$ case ((ContentType -> Const ContentType ContentType)
 -> Headers -> Const ContentType Headers)
-> Headers -> ContentType
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (ContentType -> Const ContentType ContentType)
-> Headers -> Const ContentType Headers
forall a. HasHeaders a => Lens' a ContentType
contentType Headers
h of
  ContentType
ct | Getting TransferEncodingName ContentType TransferEncodingName
-> ContentType -> TransferEncodingName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TransferEncodingName ContentType TransferEncodingName
Lens' ContentType TransferEncodingName
ctType ContentType
ct TransferEncodingName -> TransferEncodingName -> Bool
forall a. Eq a => a -> a -> Bool
== TransferEncodingName
"multipart" ->
    case Getting (First ByteString) ContentType ByteString
-> ContentType -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' ContentType ByteString
forall a.
HasParameters a =>
TransferEncodingName -> Traversal' a ByteString
rawParameter TransferEncodingName
"boundary") ContentType
ct of
      Maybe ByteString
Nothing -> MIMEParseError -> ByteString -> MIME
FailedParse MIMEParseError
MultipartBoundaryNotSpecified (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeTillEnd
      Just ByteString
boundary ->
        (NonEmpty MIMEMessage -> MIME
Multipart (NonEmpty MIMEMessage -> MIME)
-> Parser ByteString (NonEmpty MIMEMessage) -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
-> ByteString -> Parser ByteString (NonEmpty MIMEMessage)
multipart Parser ByteString
takeTillEnd ByteString
boundary)
        Parser MIME -> Parser MIME -> Parser MIME
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MIMEParseError -> ByteString -> MIME
FailedParse MIMEParseError
MultipartParseFail (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeTillEnd)
     | TransferEncodingName
-> Maybe TransferEncodingName -> ContentType -> Bool
matchContentType TransferEncodingName
"message" (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"rfc822") ContentType
ct ->
        (MIMEMessage -> MIME
Encapsulated (MIMEMessage -> MIME)
-> Parser ByteString MIMEMessage -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Headers -> BodyHandler MIME)
-> Parser (Message (MessageContext MIME) MIME)
forall a.
(Headers -> BodyHandler a) -> Parser (Message (MessageContext a) a)
message (Parser ByteString -> Headers -> BodyHandler MIME
mime' Parser ByteString
takeTillEnd))
        Parser MIME -> Parser MIME -> Parser MIME
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MIMEParseError -> ByteString -> MIME
FailedParse MIMEParseError
EncapsulatedMessageParseFail (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeTillEnd)
  ContentType
_ -> Parser MIME
part
  where
    part :: Parser MIME
part = ByteString -> MIME
Part (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeTillEnd

data MIMEParseError
  = MultipartBoundaryNotSpecified
  | MultipartParseFail
  | EncapsulatedMessageParseFail
  deriving (MIMEParseError -> MIMEParseError -> Bool
(MIMEParseError -> MIMEParseError -> Bool)
-> (MIMEParseError -> MIMEParseError -> Bool) -> Eq MIMEParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MIMEParseError -> MIMEParseError -> Bool
$c/= :: MIMEParseError -> MIMEParseError -> Bool
== :: MIMEParseError -> MIMEParseError -> Bool
$c== :: MIMEParseError -> MIMEParseError -> Bool
Eq, Int -> MIMEParseError -> ShowS
[MIMEParseError] -> ShowS
MIMEParseError -> String
(Int -> MIMEParseError -> ShowS)
-> (MIMEParseError -> String)
-> ([MIMEParseError] -> ShowS)
-> Show MIMEParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MIMEParseError] -> ShowS
$cshowList :: [MIMEParseError] -> ShowS
show :: MIMEParseError -> String
$cshow :: MIMEParseError -> String
showsPrec :: Int -> MIMEParseError -> ShowS
$cshowsPrec :: Int -> MIMEParseError -> ShowS
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 :: Parser ByteString
-> ByteString -> Parser ByteString (NonEmpty MIMEMessage)
multipart Parser ByteString
takeTillEnd ByteString
boundary =
  ByteString -> Parser ByteString ()
skipTillString ByteString
dashBoundary Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf -- FIXME transport-padding
  Parser ByteString ()
-> Parser ByteString (NonEmpty MIMEMessage)
-> Parser ByteString (NonEmpty MIMEMessage)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([MIMEMessage] -> NonEmpty MIMEMessage)
-> Parser ByteString [MIMEMessage]
-> Parser ByteString (NonEmpty MIMEMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [MIMEMessage] -> NonEmpty MIMEMessage
forall a. [a] -> NonEmpty a
fromList (Parser (Message (MessageContext MIME) MIME)
Parser ByteString MIMEMessage
part Parser ByteString MIMEMessage
-> Parser ByteString () -> Parser ByteString [MIMEMessage]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ByteString ()
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf)
  Parser ByteString (NonEmpty MIMEMessage)
-> Parser ByteString -> Parser ByteString (NonEmpty MIMEMessage)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"--" Parser ByteString (NonEmpty MIMEMessage)
-> Parser ByteString -> Parser ByteString (NonEmpty MIMEMessage)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString
takeTillEnd
  where
    delimiter :: ByteString
delimiter = ByteString
"\n--" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
boundary
    dashBoundary :: ByteString
dashBoundary = ByteString -> ByteString
B.tail ByteString
delimiter
    part :: Parser (Message (MessageContext MIME) MIME)
part = (Headers -> BodyHandler MIME)
-> Parser (Message (MessageContext MIME) MIME)
forall a.
(Headers -> BodyHandler a) -> Parser (Message (MessageContext a) a)
message (Parser ByteString -> Headers -> BodyHandler MIME
mime' (ByteString -> ByteString
trim (ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser ByteString
takeTillString ByteString
delimiter))
    trim :: ByteString -> ByteString
trim ByteString
s  -- trim trailing CR, because we only searched for LF
      | ByteString -> Bool
B.null ByteString
s = ByteString
s
      | ByteString -> Char
C8.last ByteString
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = ByteString -> ByteString
B.init ByteString
s
      | Bool
otherwise = ByteString
s

-- | Sets the @MIME-Version: 1.0@ header.
--
instance RenderMessage MIME where
  tweakHeaders :: Headers -> Headers
tweakHeaders = ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
-> Maybe ByteString -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Headers -> Identity Headers) -> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> Identity Headers) -> Headers -> Identity Headers)
-> ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
-> ASetter Headers Headers (Maybe ByteString) (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Headers
"MIME-Version") (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"1.0")
  buildBody :: Headers -> MIME -> Maybe Builder
buildBody Headers
h MIME
z = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ case MIME
z of
    Part ByteString
partbody -> ByteString -> Builder
Builder.byteString ByteString
partbody
    Encapsulated MIMEMessage
msg -> MIMEMessage -> Builder
forall ctx a. RenderMessage a => Message ctx a -> Builder
buildMessage MIMEMessage
msg
    Multipart NonEmpty MIMEMessage
xs ->
      let b :: Maybe ByteString
b = Getting (Leftmost ByteString) Headers ByteString
-> Headers -> Maybe ByteString
forall a s. Getting (Leftmost a) s a -> s -> Maybe a
firstOf ((ContentType -> Const (Leftmost ByteString) ContentType)
-> Headers -> Const (Leftmost ByteString) Headers
forall a. HasHeaders a => Lens' a ContentType
contentType ((ContentType -> Const (Leftmost ByteString) ContentType)
 -> Headers -> Const (Leftmost ByteString) Headers)
-> ((ByteString -> Const (Leftmost ByteString) ByteString)
    -> ContentType -> Const (Leftmost ByteString) ContentType)
-> Getting (Leftmost ByteString) Headers ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (Leftmost ByteString) ByteString)
-> ContentType -> Const (Leftmost ByteString) ContentType
Traversal' ContentType ByteString
mimeBoundary) Headers
h
          boundary :: Builder
boundary = Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (\ByteString
b' -> Builder
"--" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
b') Maybe ByteString
b
      in
        Builder
boundary Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> NonEmpty Builder -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Builder -> NonEmpty Builder -> NonEmpty Builder
forall a. a -> NonEmpty a -> NonEmpty a
intersperse (Builder
"\r\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
boundary Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n") ((MIMEMessage -> Builder)
-> NonEmpty MIMEMessage -> NonEmpty Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MIMEMessage -> Builder
forall ctx a. RenderMessage a => Message ctx a -> Builder
buildMessage NonEmpty MIMEMessage
xs))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
boundary Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"--\r\n"
    FailedParse MIMEParseError
_ ByteString
bs -> ByteString -> Builder
Builder.byteString 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 :: (ByteString -> [a])
-> ([a] -> ByteString) -> TransferEncodingName -> Lens' s [a]
headerSingleToList ByteString -> [a]
f [a] -> ByteString
g TransferEncodingName
k =
  (Headers -> f Headers) -> s -> f s
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> s -> f s)
-> (([a] -> f [a]) -> Headers -> f Headers)
-> ([a] -> f [a])
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TransferEncodingName
Index Headers
k ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> (([a] -> f [a]) -> Maybe ByteString -> f (Maybe ByteString))
-> ([a] -> f [a])
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> [a])
-> ([a] -> Maybe ByteString)
-> Iso (Maybe ByteString) (Maybe ByteString) [a] [a]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ([a] -> (ByteString -> [a]) -> Maybe ByteString -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [a]
f) (\[a]
l -> if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
l then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ([a] -> ByteString
g [a]
l))

headerFrom :: HasHeaders a => CharsetLookup -> Lens' a [Mailbox]
headerFrom :: CharsetLookup -> Lens' a [Mailbox]
headerFrom CharsetLookup
charsets = (ByteString -> [Mailbox])
-> ([Mailbox] -> ByteString)
-> TransferEncodingName
-> Lens' a [Mailbox]
forall s a.
HasHeaders s =>
(ByteString -> [a])
-> ([a] -> ByteString) -> TransferEncodingName -> Lens' s [a]
headerSingleToList
  ([Mailbox] -> Either String [Mailbox] -> [Mailbox]
forall b a. b -> Either a b -> b
fromRight [] (Either String [Mailbox] -> [Mailbox])
-> (ByteString -> Either String [Mailbox])
-> ByteString
-> [Mailbox]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [Mailbox] -> ByteString -> Either String [Mailbox]
forall a. Parser a -> ByteString -> Either String a
parseOnly (CharsetLookup -> Parser [Mailbox]
mailboxList CharsetLookup
charsets))
  [Mailbox] -> ByteString
renderMailboxes
  TransferEncodingName
"From"

headerAddressList :: (HasHeaders a) => CI B.ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList :: TransferEncodingName -> CharsetLookup -> Lens' a [Address]
headerAddressList TransferEncodingName
k CharsetLookup
charsets = (ByteString -> [Address])
-> ([Address] -> ByteString)
-> TransferEncodingName
-> Lens' a [Address]
forall s a.
HasHeaders s =>
(ByteString -> [a])
-> ([a] -> ByteString) -> TransferEncodingName -> Lens' s [a]
headerSingleToList
  ([Address] -> Either String [Address] -> [Address]
forall b a. b -> Either a b -> b
fromRight [] (Either String [Address] -> [Address])
-> (ByteString -> Either String [Address])
-> ByteString
-> [Address]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [Address] -> ByteString -> Either String [Address]
forall a. Parser a -> ByteString -> Either String a
parseOnly (CharsetLookup -> Parser [Address]
addressList CharsetLookup
charsets))
  [Address] -> ByteString
renderAddresses
  TransferEncodingName
k

headerTo, headerCC, headerBCC :: (HasHeaders a) => CharsetLookup -> Lens' a [Address]
headerTo :: CharsetLookup -> Lens' a [Address]
headerTo = TransferEncodingName -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
TransferEncodingName -> CharsetLookup -> Lens' a [Address]
headerAddressList TransferEncodingName
"To"
headerCC :: CharsetLookup -> Lens' a [Address]
headerCC = TransferEncodingName -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
TransferEncodingName -> CharsetLookup -> Lens' a [Address]
headerAddressList TransferEncodingName
"Cc"
headerBCC :: CharsetLookup -> Lens' a [Address]
headerBCC = TransferEncodingName -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
TransferEncodingName -> CharsetLookup -> Lens' a [Address]
headerAddressList TransferEncodingName
"Bcc"

headerDate :: HasHeaders a => Lens' a (Maybe UTCTime)
headerDate :: Lens' a (Maybe UTCTime)
headerDate = (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> ((Maybe UTCTime -> f (Maybe UTCTime)) -> Headers -> f Headers)
-> (Maybe UTCTime -> f (Maybe UTCTime))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Headers
"Date" ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> ((Maybe UTCTime -> f (Maybe UTCTime))
    -> Maybe ByteString -> f (Maybe ByteString))
-> (Maybe UTCTime -> f (Maybe UTCTime))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> Maybe UTCTime)
-> (Maybe UTCTime -> Maybe ByteString)
-> Iso
     (Maybe ByteString)
     (Maybe ByteString)
     (Maybe UTCTime)
     (Maybe UTCTime)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (ByteString -> Maybe UTCTime
parseDate (ByteString -> Maybe UTCTime) -> Maybe ByteString -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) ((UTCTime -> ByteString) -> Maybe UTCTime -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> ByteString
renderRFC5422Date)
  where
    parseDate :: ByteString -> Maybe UTCTime
parseDate =
        Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
rfc5422DateTimeFormatLax (String -> Maybe UTCTime)
-> (ByteString -> String) -> ByteString -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
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 :: CharsetLookup -> TransferEncodingName -> Lens' a (Maybe Text)
headerText CharsetLookup
charsets TransferEncodingName
k =
  (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> ((Maybe Text -> f (Maybe Text)) -> Headers -> f Headers)
-> (Maybe Text -> f (Maybe Text))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TransferEncodingName
Index Headers
k ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> ((Maybe Text -> f (Maybe Text))
    -> Maybe ByteString -> f (Maybe ByteString))
-> (Maybe Text -> f (Maybe Text))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> Maybe Text)
-> (Maybe Text -> Maybe ByteString)
-> Iso
     (Maybe ByteString) (Maybe ByteString) (Maybe Text) (Maybe Text)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CharsetLookup -> ByteString -> Text
decodeEncodedWords CharsetLookup
charsets)) ((Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeEncodedWords)

-- | Subject header.  See 'headerText' for details of conversion to @Text@.
headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)
headerSubject :: CharsetLookup -> Lens' a (Maybe Text)
headerSubject CharsetLookup
charsets = CharsetLookup -> TransferEncodingName -> Lens' a (Maybe Text)
forall a.
HasHeaders a =>
CharsetLookup -> TransferEncodingName -> Lens' a (Maybe Text)
headerText CharsetLookup
charsets TransferEncodingName
"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 :: Getter a (Maybe ByteString)
replyHeaderReferences = ((Headers -> f Headers) -> a -> f a)
-> ((Maybe ByteString -> f (Maybe ByteString))
    -> Headers -> f Headers)
-> (Maybe ByteString -> f (Maybe ByteString))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers (((Maybe ByteString -> f (Maybe ByteString))
  -> Headers -> f Headers)
 -> (Maybe ByteString -> f (Maybe ByteString)) -> a -> f a)
-> ((Maybe ByteString -> f (Maybe ByteString))
    -> Headers -> f Headers)
-> (Maybe ByteString -> f (Maybe ByteString))
-> a
-> f a
forall a b. (a -> b) -> a -> b
$ (Headers -> Maybe ByteString)
-> (Maybe ByteString -> f (Maybe ByteString))
-> Headers
-> f Headers
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Headers -> Maybe ByteString)
 -> (Maybe ByteString -> f (Maybe ByteString))
 -> Headers
 -> f Headers)
-> (Headers -> Maybe ByteString)
-> (Maybe ByteString -> f (Maybe ByteString))
-> Headers
-> f Headers
forall a b. (a -> b) -> a -> b
$ \Headers
hdrs ->
  let xs :: [ByteString]
xs = [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes
        [Getting (First ByteString) Headers ByteString
-> Headers -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' Headers ByteString
forall a.
HasHeaders a =>
TransferEncodingName -> Traversal' a ByteString
header TransferEncodingName
"references") Headers
hdrs
         Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Getting (First ByteString) Headers ByteString
-> Headers -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' Headers ByteString
forall a.
HasHeaders a =>
TransferEncodingName -> Traversal' a ByteString
header TransferEncodingName
"in-reply-to") Headers
hdrs
        , Getting (First ByteString) Headers ByteString
-> Headers -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' Headers ByteString
forall a.
HasHeaders a =>
TransferEncodingName -> Traversal' a ByteString
header TransferEncodingName
"message-id") Headers
hdrs
        ]
  in if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
xs then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
" " [ByteString]
xs)

-- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple
-- `attachments`
--
createMultipartMixedMessage
    :: B.ByteString -- ^ Boundary
    -> NonEmpty MIMEMessage -- ^ parts
    -> MIMEMessage
createMultipartMixedMessage :: ByteString -> NonEmpty MIMEMessage -> MIMEMessage
createMultipartMixedMessage ByteString
b NonEmpty MIMEMessage
attachments' =
    let hdrs :: Headers
hdrs = Headers
forall a. Monoid a => a
mempty Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
&
                ((ContentType -> Identity ContentType)
 -> Headers -> Identity Headers)
-> ContentType -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (ContentType -> Identity ContentType)
-> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a ContentType
contentType (ByteString -> ContentType
contentTypeMultipartMixed ByteString
b)
    in Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
hdrs (NonEmpty MIMEMessage -> MIME
Multipart NonEmpty MIMEMessage
attachments')

-- | Create an inline, text/plain, utf-8 encoded message
--
createTextPlainMessage :: T.Text -> MIMEMessage
createTextPlainMessage :: Text -> MIMEMessage
createTextPlainMessage Text
s = (ByteString -> MIME) -> WireEntity -> MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> MIME
Part (WireEntity -> MIMEMessage) -> WireEntity -> MIMEMessage
forall a b. (a -> b) -> a -> b
$ TransferDecoded WireEntity -> WireEntity
forall a. HasTransferEncoding a => TransferDecoded a -> a
transferEncode (TransferDecoded WireEntity -> WireEntity)
-> TransferDecoded WireEntity -> WireEntity
forall a b. (a -> b) -> a -> b
$ Decoded (Message EncStateByte ByteString)
-> Message EncStateByte ByteString
forall a. HasCharset a => Decoded a -> a
charsetEncode Decoded (Message EncStateByte ByteString)
Message () Text
msg
  where
  msg :: Message () Text
msg = Headers -> Text -> Message () Text
forall s a. Headers -> a -> Message s a
Message Headers
hdrs Text
s :: TextEntity
  cd :: ContentDisposition
cd = DispositionType -> Parameters -> ContentDisposition
ContentDisposition DispositionType
Inline Parameters
forall a. Monoid a => a
mempty
  hdrs :: Headers
hdrs = Headers
forall a. Monoid a => a
mempty
          Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ((ContentType -> Identity ContentType)
 -> Headers -> Identity Headers)
-> ContentType -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (ContentType -> Identity ContentType)
-> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a ContentType
contentType ContentType
contentTypeTextPlain
          Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter
  Headers
  Headers
  (Maybe ContentDisposition)
  (Maybe ContentDisposition)
-> Maybe ContentDisposition -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Headers
  Headers
  (Maybe ContentDisposition)
  (Maybe ContentDisposition)
forall a. HasHeaders a => Lens' a (Maybe ContentDisposition)
contentDisposition (ContentDisposition -> Maybe ContentDisposition
forall a. a -> Maybe a
Just ContentDisposition
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 :: ContentType -> String -> IO MIMEMessage
createAttachmentFromFile ContentType
ct String
fp = ContentType -> Maybe String -> ByteString -> MIMEMessage
createAttachment ContentType
ct (String -> Maybe String
forall a. a -> Maybe a
Just String
fp) (ByteString -> MIMEMessage) -> IO ByteString -> IO MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
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 :: ContentType -> Maybe String -> ByteString -> MIMEMessage
createAttachment ContentType
ct Maybe String
fp ByteString
s = ByteString -> MIME
Part (ByteString -> MIME) -> WireEntity -> MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransferDecoded WireEntity -> WireEntity
forall a. HasTransferEncoding a => TransferDecoded a -> a
transferEncode TransferDecoded WireEntity
Message EncStateByte ByteString
msg
  where
  msg :: Message EncStateByte ByteString
msg = Headers -> ByteString -> Message EncStateByte ByteString
forall s a. Headers -> a -> Message s a
Message Headers
hdrs ByteString
s
  cd :: ContentDisposition
cd = DispositionType -> Parameters -> ContentDisposition
ContentDisposition DispositionType
Attachment Parameters
cdParams
  cdParams :: Parameters
cdParams = Parameters
forall a. Monoid a => a
mempty Parameters -> (Parameters -> Parameters) -> Parameters
forall a b. a -> (a -> b) -> b
& ASetter
  Parameters
  Parameters
  (Maybe EncodedParameterValue)
  (Maybe EncodedParameterValue)
-> Maybe EncodedParameterValue -> Parameters -> Parameters
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Parameters
  Parameters
  (Maybe EncodedParameterValue)
  (Maybe EncodedParameterValue)
forall a. HasParameters a => Lens' a (Maybe EncodedParameterValue)
filenameParameter (String -> EncodedParameterValue
forall s. Cons s s Char Char => s -> EncodedParameterValue
newParameter (String -> EncodedParameterValue)
-> Maybe String -> Maybe EncodedParameterValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
fp)
  hdrs :: Headers
hdrs = Headers
forall a. Monoid a => a
mempty
          Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ((ContentType -> Identity ContentType)
 -> Headers -> Identity Headers)
-> ContentType -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (ContentType -> Identity ContentType)
-> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a ContentType
contentType ContentType
ct
          Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter
  Headers
  Headers
  (Maybe ContentDisposition)
  (Maybe ContentDisposition)
-> Maybe ContentDisposition -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Headers
  Headers
  (Maybe ContentDisposition)
  (Maybe ContentDisposition)
forall a. HasHeaders a => Lens' a (Maybe ContentDisposition)
contentDisposition (ContentDisposition -> Maybe ContentDisposition
forall a. a -> Maybe a
Just ContentDisposition
cd)

-- | Encapsulate a message as a @message/rfc822@ message.
-- You can use this in creating /forwarded/ or /bounce/ messages.
--
encapsulate :: MIMEMessage -> MIMEMessage
encapsulate :: MIMEMessage -> MIMEMessage
encapsulate = Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
hdrs (MIME -> MIMEMessage)
-> (MIMEMessage -> MIME) -> MIMEMessage -> MIMEMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MIMEMessage -> MIME
Encapsulated
  where
  hdrs :: Headers
hdrs = Headers
forall a. Monoid a => a
mempty Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ((ContentType -> Identity ContentType)
 -> Headers -> Identity Headers)
-> ContentType -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (ContentType -> Identity ContentType)
-> Headers -> Identity Headers
forall a. HasHeaders a => Lens' a ContentType
contentType ContentType
"message/rfc822"