-- This file is part of purebred-email
-- Copyright (C) 2017-2021  Fraser Tweedale
--
-- purebred-email is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

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

{- |

This module extends "Data.IMF" with types for handling MIME messages
(RFC 2045, 2046, 2183 and others).

-}
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
  , parseContentType
  , renderContentType
  , showContentType

  -- *** @multipart@ media type
  , MultipartSubtype(..)

  -- **** @boundary@ parameter
  , Boundary
  , makeBoundary
  , unBoundary
  , 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
  , setTextPlainBody

  -- *** Forward
  , encapsulate

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

import Control.Applicative
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty, fromList, intersperse)
import Data.Maybe (fromMaybe)
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.IMF
import Data.IMF.Syntax hiding (takeWhile1)
import Data.MIME.Boundary
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:

@
λ> :set -XOverloadedStrings
λ> import Data.MIME
λ> msg = 'createTextPlainMessage' "Hello, world!"
λ> s = 'renderMessage' msg
λ> Data.ByteString.Lazy.Char8.putStrLn s
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
Content-Type: text/plain; charset=us-ascii

Hello, world!
@

Optics are provided for getting and setting the __sender and recipient__
fields:

@
'headerFrom', 'headerReplyTo', 'headerTo', 'headerCC', 'headerBCC'
  :: ('HasHeaders' a)
  => 'CharsetLookup' -> Lens' a ['Address']
@

Example:

@
λ> alice = 'Single' "alice\@example.com"
λ> :t alice
alice :: 'Address'
λ> bob = 'Single' "bob\@example.net"
λ> msgFromAliceToBob = set ('headerFrom' 'defaultCharsets') [alice] . set ('headerTo' defaultCharsets) [bob] $ msg
λ> Data.ByteString.Lazy.Char8.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!
@

__NOTE__: the values @alice@ and @bob@ in the above example make use
of the __non-total__ @instance 'IsString' 'Mailbox'@.  This instance
is provided as convenience for static values.  For parsing mailboxes,
use one of:

@
Data.IMF.'Data.IMF.mailbox'      :: 'CharsetLookup' -> Parser ByteString Mailbox
Data.IMF.Text.'Data.IMF.Text.mailbox' ::                  Parser       Text Mailbox
@

The __@Subject@__ header is set via 'headerSubject'.  __Other single-valued headers__
can be set via 'headerText'.

@
λ> :{
| Data.ByteString.Lazy.Char8.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!
@

To create __multipart messages__ you need to construct a 'Boundary' value.
Boundary values should be unique (not appearing elsewhere in a message).
High-entropy random values are good.  You can use 'mkBoundary' to construct a
value (checking that the input is a legal value).  Or you can ask
/purebred-email/ to generate a conformant value, as below.

@
λ> import System.Random
λ> boundary <- getStdRandom uniform :: IO Boundary
λ> boundary
Boundary "MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w"
@

Create a __multipart message with attachment__:

@
λ> attachment = 'createAttachment' "application/json" (Just "data.json") "{\\"foo\\":42}"
λ> msg2 = 'createMultipartMixedMessage' boundary (msg :| [attachment])
λ> s2 = 'renderMessage' msg2
λ> Data.ByteString.Lazy.Char8.putStrLn s2
MIME-Version: 1.0
Content-Type: multipart/mixed;
 boundary="MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w"

--MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
Content-Type: text/plain; charset=us-ascii

Hello, world!
--MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: attachment; filename=data.json
Content-Type: application/json

{"foo":42}
--MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w--

@

__NOTE:__ for writing a '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, the leaves of (possibly nested) multipart
messages and "message/rfc822" encapsulations.  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, isTextPlain msg2)
(True,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 may be interested in the binary data and
the filename (if specified).  In the following example we get the
(optional) filenames and (decoded) body of all attachments, as a
list of tuples.  The 'attachments' traversal targets non-multipart
entities with @Content-Disposition: attachment@.  The
'transferDecoded'' optic undoes the @Content-Transfer-Encoding@ of
the entity.

@
λ> :set -XTypeFamilies
λ> 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"
λ> Data.ByteString.Lazy.Char8.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_ Data.Text.IO.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

data MultipartSubtype
  = Mixed
  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.3 RFC 2046 §5.1.3.>
  -- Independent body parts, bundled in a particular order.
  | Alternative
  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.4 RFC 2046 §5.1.4.>
  -- Each part is an alternative version of the same content
  -- (e.g. plain text and HTML), in order of increasing faithfulness
  -- to the original content.
  | Digest
  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.5 RFC 2046 §5.1.5.>
  -- Collection of messages. Parts should have @Content-Type: message/rfc822@.
  | Parallel
  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.6 RFC 2046 §5.1.6.>
  -- Independent body parts, order not significants.  Parts may be
  -- displayed in parallel if the system supports it.
  | Related
      ContentType {- ^ @type@ -}
      (Maybe B.ByteString) {- ^ @start@ -}
      (Maybe B.ByteString) {- ^ @start-info@ -}
  -- ^ <https://www.rfc-editor.org/rfc/rfc2387.html RFC 2387.>
  -- Aggregate or compound objects.
  | Signed B.ByteString {- ^ protocol -} B.ByteString {- ^ micalg -}
  -- ^ <https://www.rfc-editor.org/rfc/rfc1847.html#section-2.1 RFC 1847 §2.1.>
  -- Signed messages.
  | Encrypted B.ByteString {- protocol -}
  -- ^ <https://www.rfc-editor.org/rfc/rfc1847.html#section-2.2 RFC 1847 §2.2.>
  | Report B.ByteString {- report-type -}
  -- ^ <https://www.rfc-editor.org/rfc/rfc6522.html RFC 6522>.
  -- Electronic mail reports.
  | Multilingual
  -- ^ <https://www.rfc-editor.org/rfc/rfc8255.html RFC 8255>.
  -- Multilingual messages.  The first part should be a multilingual
  -- explanatory preface.  Subsequent parts MUST have a
  -- @Content-Language@ and a @Content-Type@ field, and MAY have a
  -- @Content-Translation-Type@ field.
  | Unrecognised (CI B.ByteString)
  deriving (MultipartSubtype -> MultipartSubtype -> Bool
(MultipartSubtype -> MultipartSubtype -> Bool)
-> (MultipartSubtype -> MultipartSubtype -> Bool)
-> Eq MultipartSubtype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultipartSubtype -> MultipartSubtype -> Bool
$c/= :: MultipartSubtype -> MultipartSubtype -> Bool
== :: MultipartSubtype -> MultipartSubtype -> Bool
$c== :: MultipartSubtype -> MultipartSubtype -> Bool
Eq, Int -> MultipartSubtype -> ShowS
[MultipartSubtype] -> ShowS
MultipartSubtype -> String
(Int -> MultipartSubtype -> ShowS)
-> (MultipartSubtype -> String)
-> ([MultipartSubtype] -> ShowS)
-> Show MultipartSubtype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultipartSubtype] -> ShowS
$cshowList :: [MultipartSubtype] -> ShowS
show :: MultipartSubtype -> String
$cshow :: MultipartSubtype -> String
showsPrec :: Int -> MultipartSubtype -> ShowS
$cshowsPrec :: Int -> MultipartSubtype -> ShowS
Show)

-- | 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 MultipartSubtype Boundary (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 MultipartSubtype
sub Boundary
b 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
. MultipartSubtype -> Boundary -> NonEmpty MIMEMessage -> MIME
Multipart MultipartSubtype
sub Boundary
b (NonEmpty MIMEMessage -> MIMEMessage)
-> f (NonEmpty MIMEMessage) -> f MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MIMEMessage -> f MIMEMessage)
-> NonEmpty MIMEMessage -> f (NonEmpty MIMEMessage)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((WireEntity -> f WireEntity) -> MIMEMessage -> f MIMEMessage
Traversal' MIMEMessage WireEntity
entities WireEntity -> f WireEntity
f) 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

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)

-- | <https://www.rfc-editor.org/rfc/rfc6657.html RFC 6657>
-- specifies that each subtype of the @text@ media type can define
-- its own default value for the @charset@ parameter, including the
-- absense of any default.  It can also specify that the charset
-- information is transported inside the payload (such as in
-- @text/xml@.  Behaviour for common media types includes:
--
-- [@text/plain@] Default: @us-ascii@
--   (<https://www.rfc-editor.org/rfc/rfc6657.html#section-4 RFC 6657>)
-- [@text/csv@] Default: @utf-8@
--   (<https://www.rfc-editor.org/rfc/rfc7111.html#section-5.1 RFC 7111>)
-- [@text/markdown@] No default; @charset@ parameter is REQUIRED
--   (<https://www.rfc-editor.org/rfc/rfc7763.html#section-2 RFC 7763>)
-- [@text/enriched@] Default: @us-ascii@
--   (<https://www.rfc-editor.org/rfc/rfc1896.html RFC 1896>)
-- [@text/rtf@] Decoded as @us-ascii@.  Serialised RTF must be 7-bit
--   ASCII, with the character set declared in the payload.
--   Decoding RTF is outside the scope of this library.
--   See <https://www.iana.org/assignments/media-types/text/rtf>.
--
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
        InPayload 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
        InPayloadOrParameter Maybe TransferEncodingName
-> ByteString -> Maybe TransferEncodingName
f -> Maybe TransferEncodingName
-> ByteString -> Maybe TransferEncodingName
f (((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) (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)
      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
  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
  = InPayload (B.ByteString -> Maybe CharsetName)
  -- ^ Charset should be declared within payload (e.g. rtf).
  --   The given function reads the payload and returns the charset,
  --   or @Nothing@ if the charset cannot be determined or defaulted.
  | InParameter (Maybe CharsetName)
  -- ^ Charset may be declared in the @charset@ parameter,
  --   with optional fallback to the given default.
  | InPayloadOrParameter (Maybe CharsetName -> B.ByteString -> Maybe CharsetName)
  -- ^ Charset could be specified in payload or parameter.  The function
  -- parameter takes the value of the charset parameter (which may be @Nothing@
  -- and the payload, and returns the character set that should be used (or
  -- @Nothing@ if a character set cannot be determined or defaulted.

-- | 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
InPayload (Maybe TransferEncodingName
-> ByteString -> Maybe TransferEncodingName
forall a b. a -> b -> a
const (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii")))

  -- https://tools.ietf.org/html/rfc2854
  -- The default is ambiguous; using us-ascii for now
  , (TransferEncodingName
"html", (Maybe TransferEncodingName
 -> ByteString -> Maybe TransferEncodingName)
-> EntityCharsetSource
InPayloadOrParameter (\Maybe TransferEncodingName
_param ByteString
_payload -> TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii")) -- FIXME

  -- 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", (Maybe TransferEncodingName
 -> ByteString -> Maybe TransferEncodingName)
-> EntityCharsetSource
InPayloadOrParameter (\Maybe TransferEncodingName
_param ByteString
_payload -> TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"utf-8")) -- FIXME

  -- https://tools.ietf.org/html/rfc1896.html
  , (TransferEncodingName
"enriched", Maybe TransferEncodingName -> EntityCharsetSource
InParameter (TransferEncodingName -> Maybe TransferEncodingName
forall a. a -> Maybe a
Just TransferEncodingName
"us-ascii"))
  ]

-- | @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/...; boundary=asdf@
contentTypeMultipart :: MultipartSubtype -> Boundary -> ContentType
contentTypeMultipart :: MultipartSubtype -> Boundary -> ContentType
contentTypeMultipart MultipartSubtype
subtype Boundary
boundary =
  TransferEncodingName
-> TransferEncodingName -> Parameters -> ContentType
ContentType TransferEncodingName
"multipart" TransferEncodingName
sub Parameters
forall a. Monoid a => a
mempty
    ContentType -> (ContentType -> ContentType) -> ContentType
forall a b. a -> (a -> b) -> b
& TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"boundary" (Boundary -> ByteString
unBoundary Boundary
boundary)
    ContentType -> (ContentType -> ContentType) -> ContentType
forall a b. a -> (a -> b) -> b
& ContentType -> ContentType
appendParams
  where
    setParam :: TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
k ByteString
v = ASetter
  t t (Maybe EncodedParameterValue) (Maybe EncodedParameterValue)
-> Maybe EncodedParameterValue -> t -> t
forall s t a b. ASetter s t a b -> b -> s -> t
set (TransferEncodingName -> Lens' t (Maybe EncodedParameterValue)
forall a.
HasParameters a =>
TransferEncodingName -> Lens' a (Maybe EncodedParameterValue)
parameter TransferEncodingName
k) (EncodedParameterValue -> Maybe EncodedParameterValue
forall a. a -> Maybe a
Just (EncodedParameterValue -> Maybe EncodedParameterValue)
-> EncodedParameterValue -> Maybe EncodedParameterValue
forall a b. (a -> b) -> a -> b
$ 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
v)
    (TransferEncodingName
sub, ContentType -> ContentType
appendParams) = case MultipartSubtype
subtype of
      MultipartSubtype
Mixed -> (TransferEncodingName
"mixed", ContentType -> ContentType
forall a. a -> a
id)
      MultipartSubtype
Alternative -> (TransferEncodingName
"alternative", ContentType -> ContentType
forall a. a -> a
id)
      MultipartSubtype
Digest -> (TransferEncodingName
"digest", ContentType -> ContentType
forall a. a -> a
id)
      MultipartSubtype
Parallel -> (TransferEncodingName
"parallel", ContentType -> ContentType
forall a. a -> a
id)
      MultipartSubtype
Multilingual -> (TransferEncodingName
"multilingual", ContentType -> ContentType
forall a. a -> a
id)
      Report ByteString
typ -> (TransferEncodingName
"report", TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"report-type" ByteString
typ)
      Signed ByteString
proto ByteString
micalg -> (TransferEncodingName
"signed", TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"protocol" ByteString
proto (ContentType -> ContentType)
-> (ContentType -> ContentType) -> ContentType -> ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"micalg" ByteString
micalg)
      Encrypted ByteString
proto -> (TransferEncodingName
"encrypted", TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"protocol" ByteString
proto)
      Related ContentType
typ Maybe ByteString
start Maybe ByteString
startInfo ->
        ( TransferEncodingName
"related"
        , (ContentType -> ContentType)
-> (ByteString -> ContentType -> ContentType)
-> Maybe ByteString
-> ContentType
-> ContentType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContentType -> ContentType
forall a. a -> a
id (TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"start") Maybe ByteString
start
          (ContentType -> ContentType)
-> (ContentType -> ContentType) -> ContentType -> ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentType -> ContentType)
-> (ByteString -> ContentType -> ContentType)
-> Maybe ByteString
-> ContentType
-> ContentType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContentType -> ContentType
forall a. a -> a
id (TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"start-info") Maybe ByteString
startInfo
          (ContentType -> ContentType)
-> (ContentType -> ContentType) -> ContentType -> ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferEncodingName -> ByteString -> ContentType -> ContentType
forall t.
HasParameters t =>
TransferEncodingName -> ByteString -> t -> t
setParam TransferEncodingName
"type" (ContentType -> ByteString
renderContentType ContentType
typ)
        )
      Unrecognised TransferEncodingName
sub' -> (TransferEncodingName
sub', ContentType -> ContentType
forall a. a -> a
id)

-- | @multipart/mixed; boundary=asdf@
contentTypeMultipartMixed :: Boundary -> ContentType
contentTypeMultipartMixed :: Boundary -> ContentType
contentTypeMultipartMixed = MultipartSubtype -> Boundary -> ContentType
contentTypeMultipart MultipartSubtype
Mixed

-- | 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.
--
-- __Note__: when dealing with 'Multipart' or 'Encapsulated'
-- messages, the @Content-Type@ header will be overridden when
-- serialising the message.  This avoids scenarios where the
-- @Content-Type@ does not match the structure of the message.  In
-- general, the @Content-Type@ header should be treated as "read
-- only" for multipart or encapsulated message.
--
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.IMF.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"


-- | Traversal of @boundary@ parameter (which may be unspecified)
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 ContentType -> Either MIMEParseError (MultipartSubtype, Boundary)
prepMultipart ContentType
ct of
          Left MIMEParseError
err              -> MIMEParseError -> ByteString -> MIME
FailedParse MIMEParseError
err (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeTillEnd
          Right (MultipartSubtype
sub, Boundary
boundary) ->
            MultipartSubtype -> Boundary -> NonEmpty MIMEMessage -> MIME
Multipart MultipartSubtype
sub Boundary
boundary (NonEmpty MIMEMessage -> MIME)
-> Parser ByteString (NonEmpty MIMEMessage) -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
-> Boundary -> Parser ByteString (NonEmpty MIMEMessage)
multipart Parser ByteString
takeTillEnd Boundary
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
_ -> ByteString -> MIME
Part (ByteString -> MIME) -> Parser ByteString -> Parser MIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
takeTillEnd
  where
    prepMultipart :: ContentType -> Either MIMEParseError (MultipartSubtype, Boundary)
prepMultipart ContentType
ct =
      (,) (MultipartSubtype -> Boundary -> (MultipartSubtype, Boundary))
-> Either MIMEParseError MultipartSubtype
-> Either MIMEParseError (Boundary -> (MultipartSubtype, Boundary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentType -> Either MIMEParseError MultipartSubtype
parseSubtype ContentType
ct Either MIMEParseError (Boundary -> (MultipartSubtype, Boundary))
-> Either MIMEParseError Boundary
-> Either MIMEParseError (MultipartSubtype, Boundary)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ContentType -> Either MIMEParseError Boundary
forall s. HasParameters s => s -> Either MIMEParseError Boundary
parseBoundary ContentType
ct
    parseBoundary :: s -> Either MIMEParseError Boundary
parseBoundary s
ct =
      TransferEncodingName -> s -> Either MIMEParseError ByteString
forall s.
HasParameters s =>
TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
"boundary" s
ct
      Either MIMEParseError ByteString
-> (ByteString -> Either MIMEParseError Boundary)
-> Either MIMEParseError Boundary
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASetter
  (Either ByteString Boundary)
  (Either MIMEParseError Boundary)
  ByteString
  MIMEParseError
-> (ByteString -> MIMEParseError)
-> Either ByteString Boundary
-> Either MIMEParseError Boundary
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Either ByteString Boundary)
  (Either MIMEParseError Boundary)
  ByteString
  MIMEParseError
forall a c b. Prism (Either a c) (Either b c) a b
_Left (TransferEncodingName -> ByteString -> MIMEParseError
InvalidParameterValue TransferEncodingName
"boundary") (Either ByteString Boundary -> Either MIMEParseError Boundary)
-> (ByteString -> Either ByteString Boundary)
-> ByteString
-> Either MIMEParseError Boundary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString Boundary
makeBoundary
    getRequiredParam :: TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
k =
      Either MIMEParseError ByteString
-> (ByteString -> Either MIMEParseError ByteString)
-> Maybe ByteString
-> Either MIMEParseError ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MIMEParseError -> Either MIMEParseError ByteString
forall a b. a -> Either a b
Left (MIMEParseError -> Either MIMEParseError ByteString)
-> MIMEParseError -> Either MIMEParseError ByteString
forall a b. (a -> b) -> a -> b
$ TransferEncodingName -> MIMEParseError
RequiredParameterMissing TransferEncodingName
k) ByteString -> Either MIMEParseError ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either MIMEParseError ByteString)
-> (s -> Maybe ByteString) -> s -> Either MIMEParseError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First ByteString) s ByteString -> s -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' s ByteString
forall a.
HasParameters a =>
TransferEncodingName -> Traversal' a ByteString
rawParameter TransferEncodingName
k)
    getOptionalParam :: TransferEncodingName -> s -> Either a (Maybe ByteString)
getOptionalParam TransferEncodingName
k =
      Maybe ByteString -> Either a (Maybe ByteString)
forall a b. b -> Either a b
Right (Maybe ByteString -> Either a (Maybe ByteString))
-> (s -> Maybe ByteString) -> s -> Either a (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First ByteString) s ByteString -> s -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (TransferEncodingName -> Traversal' s ByteString
forall a.
HasParameters a =>
TransferEncodingName -> Traversal' a ByteString
rawParameter TransferEncodingName
k)
    parseSubtype :: ContentType -> Either MIMEParseError MultipartSubtype
parseSubtype ContentType
ct = case 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
ctSubtype ContentType
ct of
      TransferEncodingName
"mixed"         -> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultipartSubtype
Mixed
      TransferEncodingName
"alternative"   -> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultipartSubtype
Alternative
      TransferEncodingName
"digest"        -> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultipartSubtype
Digest
      TransferEncodingName
"parallel"      -> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultipartSubtype
Parallel
      TransferEncodingName
"multilingual"  -> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultipartSubtype
Multilingual
      TransferEncodingName
"report"        -> ByteString -> MultipartSubtype
Report (ByteString -> MultipartSubtype)
-> Either MIMEParseError ByteString
-> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransferEncodingName
-> ContentType -> Either MIMEParseError ByteString
forall s.
HasParameters s =>
TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
"report-type" ContentType
ct
      TransferEncodingName
"signed"        -> ByteString -> ByteString -> MultipartSubtype
Signed
                          (ByteString -> ByteString -> MultipartSubtype)
-> Either MIMEParseError ByteString
-> Either MIMEParseError (ByteString -> MultipartSubtype)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransferEncodingName
-> ContentType -> Either MIMEParseError ByteString
forall s.
HasParameters s =>
TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
"protocol" ContentType
ct
                          Either MIMEParseError (ByteString -> MultipartSubtype)
-> Either MIMEParseError ByteString
-> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TransferEncodingName
-> ContentType -> Either MIMEParseError ByteString
forall s.
HasParameters s =>
TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
"micalg" ContentType
ct
      TransferEncodingName
"encrypted"     -> ByteString -> MultipartSubtype
Encrypted (ByteString -> MultipartSubtype)
-> Either MIMEParseError ByteString
-> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransferEncodingName
-> ContentType -> Either MIMEParseError ByteString
forall s.
HasParameters s =>
TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
"protocol" ContentType
ct
      TransferEncodingName
"related"       -> ContentType
-> Maybe ByteString -> Maybe ByteString -> MultipartSubtype
Related
                          (ContentType
 -> Maybe ByteString -> Maybe ByteString -> MultipartSubtype)
-> Either MIMEParseError ContentType
-> Either
     MIMEParseError
     (Maybe ByteString -> Maybe ByteString -> MultipartSubtype)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( TransferEncodingName
-> ContentType -> Either MIMEParseError ByteString
forall s.
HasParameters s =>
TransferEncodingName -> s -> Either MIMEParseError ByteString
getRequiredParam TransferEncodingName
"type" ContentType
ct
                              Either MIMEParseError ByteString
-> (ByteString -> Either MIMEParseError ContentType)
-> Either MIMEParseError ContentType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
s -> Either MIMEParseError ContentType
-> (ContentType -> Either MIMEParseError ContentType)
-> Maybe ContentType
-> Either MIMEParseError ContentType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MIMEParseError -> Either MIMEParseError ContentType
forall a b. a -> Either a b
Left (MIMEParseError -> Either MIMEParseError ContentType)
-> MIMEParseError -> Either MIMEParseError ContentType
forall a b. (a -> b) -> a -> b
$ TransferEncodingName -> ByteString -> MIMEParseError
InvalidParameterValue TransferEncodingName
"type" ByteString
s) ContentType -> Either MIMEParseError ContentType
forall a b. b -> Either a b
Right
                                          (((ContentType -> Const (First ContentType) ContentType)
 -> ByteString -> Const (First ContentType) ByteString)
-> ByteString -> Maybe ContentType
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Parser ContentType -> Fold ByteString ContentType
forall s a. Cons s s Word8 Word8 => Parser a -> Fold s a
parsed Parser ContentType
parseContentType) ByteString
s)
                              )
                          Either
  MIMEParseError
  (Maybe ByteString -> Maybe ByteString -> MultipartSubtype)
-> Either MIMEParseError (Maybe ByteString)
-> Either MIMEParseError (Maybe ByteString -> MultipartSubtype)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TransferEncodingName
-> ContentType -> Either MIMEParseError (Maybe ByteString)
forall s a.
HasParameters s =>
TransferEncodingName -> s -> Either a (Maybe ByteString)
getOptionalParam TransferEncodingName
"start" ContentType
ct
                          Either MIMEParseError (Maybe ByteString -> MultipartSubtype)
-> Either MIMEParseError (Maybe ByteString)
-> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TransferEncodingName
-> ContentType -> Either MIMEParseError (Maybe ByteString)
forall s a.
HasParameters s =>
TransferEncodingName -> s -> Either a (Maybe ByteString)
getOptionalParam TransferEncodingName
"start-info" ContentType
ct
      TransferEncodingName
unrecognised    -> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultipartSubtype -> Either MIMEParseError MultipartSubtype)
-> MultipartSubtype -> Either MIMEParseError MultipartSubtype
forall a b. (a -> b) -> a -> b
$ TransferEncodingName -> MultipartSubtype
Unrecognised TransferEncodingName
unrecognised

data MIMEParseError
  = RequiredParameterMissing (CI B.ByteString)
  | InvalidParameterValue (CI B.ByteString) B.ByteString
  | 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
  -> Boundary             -- ^ boundary, sans leading "--"
  -> Parser (NonEmpty MIMEMessage)
multipart :: Parser ByteString
-> Boundary -> Parser ByteString (NonEmpty MIMEMessage)
multipart Parser ByteString
takeTillEnd Boundary
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
<> Boundary -> ByteString
unBoundary Boundary
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 :: MIME -> Headers -> Headers
tweakHeaders MIME
b Headers
h =
    Headers
h
    Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& 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")
    Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& Headers -> Headers
setContentType
    where
      setContentType :: Headers -> Headers
setContentType = case MIME
b of
        Multipart MultipartSubtype
sub Boundary
boundary NonEmpty MIMEMessage
_  -> ((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 (MultipartSubtype -> Boundary -> ContentType
contentTypeMultipart MultipartSubtype
sub Boundary
boundary)
        Encapsulated MIMEMessage
_msg         -> ((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"
        MIME
_                         -> Headers -> Headers
forall a. a -> a
id
  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 MultipartSubtype
_sub Boundary
b NonEmpty MIMEMessage
xs ->
      let
        boundary :: Builder
boundary = Builder
"--" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString (Boundary -> ByteString
unBoundary Boundary
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

-- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple
-- `attachments`
--
createMultipartMixedMessage
    :: Boundary
    -> NonEmpty MIMEMessage -- ^ parts
    -> MIMEMessage
createMultipartMixedMessage :: Boundary -> NonEmpty MIMEMessage -> MIMEMessage
createMultipartMixedMessage Boundary
b NonEmpty MIMEMessage
attachments' =
  let hdrs :: Headers
hdrs = [(TransferEncodingName, ByteString)] -> Headers
Headers [] 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 (Boundary -> ContentType
contentTypeMultipartMixed Boundary
b)
  in Headers -> MIME -> MIMEMessage
forall s a. Headers -> a -> Message s a
Message Headers
hdrs (MultipartSubtype -> Boundary -> NonEmpty MIMEMessage -> MIME
Multipart MultipartSubtype
Mixed Boundary
b NonEmpty MIMEMessage
attachments')

-- | Create an inline, text/plain, utf-8 encoded message
--
createTextPlainMessage :: T.Text -> MIMEMessage
createTextPlainMessage :: Text -> MIMEMessage
createTextPlainMessage Text
s = Text -> Message Any () -> MIMEMessage
forall ctx a. Text -> Message ctx a -> MIMEMessage
setTextPlainBody Text
s (Headers -> () -> Message Any ()
forall s a. Headers -> a -> Message s a
Message ([(TransferEncodingName, ByteString)] -> Headers
Headers []) ())

-- | Set an inline, @text/plain@, utf-8 encoded message body
--
setTextPlainBody :: T.Text -> Message ctx a -> MIMEMessage
setTextPlainBody :: Text -> Message ctx a -> MIMEMessage
setTextPlainBody Text
s =
  (ByteString -> MIME) -> WireEntity -> MIMEMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> MIME
Part
  (WireEntity -> MIMEMessage)
-> (Message ctx a -> WireEntity) -> Message ctx a -> MIMEMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message EncStateByte ByteString -> WireEntity
forall a. HasTransferEncoding a => TransferDecoded a -> a
transferEncode
  (Message EncStateByte ByteString -> WireEntity)
-> (Message ctx a -> Message EncStateByte ByteString)
-> Message ctx a
-> WireEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message () Text -> Message EncStateByte ByteString
forall a. HasCharset a => Decoded a -> a
charsetEncode
  (Message () Text -> Message EncStateByte ByteString)
-> (Message ctx a -> Message () Text)
-> Message ctx a
-> Message EncStateByte ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  (Message () Text)
  (Message () Text)
  (Maybe ContentDisposition)
  (Maybe ContentDisposition)
-> Maybe ContentDisposition -> Message () Text -> Message () Text
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Message () Text)
  (Message () Text)
  (Maybe ContentDisposition)
  (Maybe ContentDisposition)
forall a. HasHeaders a => Lens' a (Maybe ContentDisposition)
contentDisposition (ContentDisposition -> Maybe ContentDisposition
forall a. a -> Maybe a
Just (ContentDisposition -> Maybe ContentDisposition)
-> ContentDisposition -> Maybe ContentDisposition
forall a b. (a -> b) -> a -> b
$ DispositionType -> Parameters -> ContentDisposition
ContentDisposition DispositionType
Inline Parameters
forall a. Monoid a => a
mempty)
  (Message () Text -> Message () Text)
-> (Message ctx a -> Message () Text)
-> Message ctx a
-> Message () Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (Message () Text) (Message () Text) ContentType ContentType
-> ContentType -> Message () Text -> Message () Text
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Message () Text) (Message () Text) ContentType ContentType
forall a. HasHeaders a => Lens' a ContentType
contentType ContentType
contentTypeTextPlain
  (Message () Text -> Message () Text)
-> (Message ctx a -> Message () Text)
-> Message ctx a
-> Message () Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (Message ctx a) (Message () Text) a Text
-> Text -> Message ctx a -> Message () Text
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Message ctx a) (Message () Text) a Text
forall ctx a ctx' b. Lens (Message ctx a) (Message ctx' b) a b
body Text
s

-- | 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 = [(TransferEncodingName, ByteString)] -> Headers
Headers []
          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 = [(TransferEncodingName, ByteString)] -> Headers
Headers [] 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"