-- This file is part of purebred-email
-- Copyright (C) 2017-2021  Fraser Tweedale and Róman Joost
--
-- 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 AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

{- |

Internet Message Format (IMF), which is used for electronic mail
(email), as specified by
<https://tools.ietf.org/html/rfc5322 RFC 5322> and updated by
<https://tools.ietf.org/html/rfc6854 RFC 6854>.

The parser allows LF line endings in addition to CRLF.  RFC 5322
specifies CRLF line endings but LF-only is common in on-disk
formats.  Serialisation functions produces CRLF line endings.

The main parsing function is 'message'.  It takes a second function
that can inspect the headers to determine how to parse the body.

@
'message' :: ('Headers' -> 'BodyHandler' a) -> Parser ('Message' ctx a)
@

The 'Message' type is parameterised over the body type, and a
phantom type that can be used for context.

@
data 'Message' ctx a = 'Message' 'Headers' a
@

Headers and body can be accessed via the 'headers', 'header' and
'body' optics.

@
'headers' :: 'HasHeaders' a => Lens'       a         Headers
headers ::                 Lens' ('Message' ctx b) Headers

'header' :: 'HasHeaders' a => CI B.ByteString -> Traversal'        a        B.ByteString
header ::                 CI B.ByteString -> Traversal' ('Message' ctx b) B.ByteString
header ::                 CI B.ByteString -> Traversal'     'Headers'     B.ByteString

'body' :: Lens ('Message' ctx a) (Message ctx' b) a b
@

The following example program parses an input, interpreting the body
as a raw @ByteString@, and prints the subject (if present), the
number of headers and the body length.  The message context type is
@()@.

@
analyse :: B.ByteString -> IO ()
analyse input =
  case 'parse' ('message' (const takeByteString)) of
    Left errMsg -> hPutStrLn stderr errMsg *> exitFailure
    Right (msg :: Message () B.ByteString) -> do
      T.putStrLn $ "subject: " <> foldOf ('headerSubject' 'defaultCharsets') msg
      putStrLn $ "num headers: " <> show (length (view 'headers' msg))
      putStrLn $ "body length: " <> show (B.length (view 'body' msg))
@

-}
module Data.IMF
  (
  -- * Message types
    Message(..)
  , message
  , MessageContext
  , BodyHandler(..)
  , body
  , EqMessage(..)

  -- * Replying
  , reply
  , ReplySettings(ReplySettings)
  , defaultReplySettings
  , ReplyMode(..)
  , ReplyFromMode(..)
  , ReplyFromRewriteMode(..)
  , SelfInRecipientsMode(..)
  , AuthorMailboxes
  , replyMode
  , replyFromMode
  , replyFromRewriteMode
  , selfInRecipientsMode
  , authorMailboxes

  -- * Headers
  , Header
  , HasHeaders(..)
  , headerList
  , Headers(..)

  -- ** Date and Time
  , headerDate
  , dateTime

  -- ** Originator
  , headerFrom
  , headerReplyTo

  -- ** Destination Address
  , headerTo
  , headerCC
  , headerBCC

  -- ** Identification
  , headerMessageID
  , headerInReplyTo
  , headerReferences

  -- ** Informational
  , headerSubject

  -- ** Arbitrary headers
  , header
  , headerText

  -- * Types

  -- ** Message ID
  , MessageID
  , parseMessageID
  , buildMessageID
  , renderMessageID

  -- ** Address types
  , Address(..)
  , address
  , addressList
  , AddrSpec(..)
  , Domain(..)
  , Mailbox(..)
  , mailbox
  , mailboxList

  -- * Parsers
  , parse
  , parsed
  , parsePrint
  , crlf
  , quotedString

  -- * Helpers
  , field

  -- * Serialisation
  , buildMessage
  , renderMessage
  , RenderMessage(..)
  , renderRFC5322Date
  , buildFields
  , buildField
  , renderAddressSpec
  , renderMailbox
  , renderMailboxes
  , renderAddress
  , renderAddresses
  ) where

import Control.Applicative
import Data.Either (fromRight)
import Data.Foldable (fold, toList)
import Data.Function (on)
import Data.List (find, findIndex, intersperse)
import Data.List.NonEmpty (NonEmpty, head, intersperse)
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.Monoid (First(..))
import Data.String (IsString(..))
import Data.Word (Word8)
import GHC.Generics (Generic)

import Control.DeepSeq (NFData)
import Control.Lens
import Control.Lens.Cons.Extras (recons)
import Data.Attoparsec.ByteString as A hiding (parse, take)
import Data.Attoparsec.ByteString.Char8 (char8)
import qualified Data.Attoparsec.ByteString.Lazy as AL
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Builder.Prim as Prim
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time (ZonedTime, defaultTimeLocale, formatTime)

import Data.IMF.Syntax
  ( CI, ci, mk, original
  , (<<>>), foldMany, foldMany1Sep
  , char, fromChar, isAtext, isQtext, isVchar, isWsp
  , optionalCFWS, word, wsp, vchar, optionalFWS, crlf
  , domainLiteral, dotAtom, dotAtomText, localPart, quotedString
  )
import {-# SOURCE #-} Data.IMF.Text (readMailbox)
import Data.IMF.DateTime (dateTime)
import Data.MIME.Charset
import Data.MIME.EncodedWord
import Data.MIME.TransferEncoding (transferEncode)

type Header = (CI B.ByteString, B.ByteString)
newtype Headers = Headers [Header]
  deriving (Headers -> Headers -> Bool
(Headers -> Headers -> Bool)
-> (Headers -> Headers -> Bool) -> Eq Headers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Headers -> Headers -> Bool
$c/= :: Headers -> Headers -> Bool
== :: Headers -> Headers -> Bool
$c== :: Headers -> Headers -> Bool
Eq, Int -> Headers -> ShowS
[Headers] -> ShowS
Headers -> String
(Int -> Headers -> ShowS)
-> (Headers -> String) -> ([Headers] -> ShowS) -> Show Headers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Headers] -> ShowS
$cshowList :: [Headers] -> ShowS
show :: Headers -> String
$cshow :: Headers -> String
showsPrec :: Int -> Headers -> ShowS
$cshowsPrec :: Int -> Headers -> ShowS
Show, (forall x. Headers -> Rep Headers x)
-> (forall x. Rep Headers x -> Headers) -> Generic Headers
forall x. Rep Headers x -> Headers
forall x. Headers -> Rep Headers x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Headers x -> Headers
$cfrom :: forall x. Headers -> Rep Headers x
Generic, Headers -> ()
(Headers -> ()) -> NFData Headers
forall a. (a -> ()) -> NFData a
rnf :: Headers -> ()
$crnf :: Headers -> ()
NFData)

class HasHeaders a where
  headers :: Lens' a Headers

instance HasHeaders Headers where
  headers :: (Headers -> f Headers) -> Headers -> f Headers
headers = (Headers -> f Headers) -> Headers -> f Headers
forall a. a -> a
id

type instance Index Headers = CI B.ByteString
type instance IxValue Headers = B.ByteString

instance Ixed Headers where
  ix :: Index Headers -> Traversal' Headers (IxValue Headers)
ix = Index Headers
-> (IxValue Headers -> f (IxValue Headers)) -> Headers -> f Headers
forall a. HasHeaders a => CI ByteString -> Traversal' a ByteString
header

hdriso :: Iso' Headers [(CI B.ByteString, B.ByteString)]
hdriso :: p [(CI ByteString, ByteString)] (f [(CI ByteString, ByteString)])
-> p Headers (f Headers)
hdriso = (Headers -> [(CI ByteString, ByteString)])
-> ([(CI ByteString, ByteString)] -> Headers)
-> Iso
     Headers
     Headers
     [(CI ByteString, ByteString)]
     [(CI ByteString, ByteString)]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Headers [(CI ByteString, ByteString)]
xs) -> [(CI ByteString, ByteString)]
xs) [(CI ByteString, ByteString)] -> Headers
Headers

-- | Acts upon the first occurrence of the header only.
--
instance At Headers where
  at :: Index Headers -> Lens' Headers (Maybe (IxValue Headers))
at Index Headers
k = ([(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)])
-> Headers -> f Headers
Iso
  Headers
  Headers
  [(CI ByteString, ByteString)]
  [(CI ByteString, ByteString)]
hdriso (([(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)])
 -> Headers -> f Headers)
-> ((Maybe ByteString -> f (Maybe ByteString))
    -> [(CI ByteString, ByteString)]
    -> f [(CI ByteString, ByteString)])
-> (Maybe ByteString -> f (Maybe ByteString))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> f (Maybe ByteString))
-> [(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)]
Lens' [(CI ByteString, ByteString)] (Maybe ByteString)
l
    where
    l :: Lens' [(CI B.ByteString, B.ByteString)] (Maybe B.ByteString)
    l :: (Maybe ByteString -> f (Maybe ByteString))
-> [(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)]
l Maybe ByteString -> f (Maybe ByteString)
f [(CI ByteString, ByteString)]
kv =
      let
        i :: Maybe Int
i = ((CI ByteString, ByteString) -> Bool)
-> [(CI ByteString, ByteString)] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
Index Headers
k) (CI ByteString -> Bool)
-> ((CI ByteString, ByteString) -> CI ByteString)
-> (CI ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI ByteString, ByteString) -> CI ByteString
forall a b. (a, b) -> a
fst) [(CI ByteString, ByteString)]
kv
        g :: Maybe ByteString -> [(CI ByteString, ByteString)]
g Maybe ByteString
Nothing = [(CI ByteString, ByteString)]
-> (Int -> [(CI ByteString, ByteString)])
-> Maybe Int
-> [(CI ByteString, ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(CI ByteString, ByteString)]
kv (\Int
j -> Int
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. Int -> [a] -> [a]
take Int
j [(CI ByteString, ByteString)]
kv [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. Semigroup a => a -> a -> a
<> Int
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. Int -> [a] -> [a]
drop (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(CI ByteString, ByteString)]
kv) Maybe Int
i
        g (Just ByteString
v) = [(CI ByteString, ByteString)]
-> (Int -> [(CI ByteString, ByteString)])
-> Maybe Int
-> [(CI ByteString, ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((CI ByteString
Index Headers
k,ByteString
v)(CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(CI ByteString, ByteString)]
kv) (\Int
j -> ASetter
  [(CI ByteString, ByteString)]
  [(CI ByteString, ByteString)]
  (CI ByteString, ByteString)
  (CI ByteString, ByteString)
-> (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)]
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index [(CI ByteString, ByteString)]
-> Traversal'
     [(CI ByteString, ByteString)]
     (IxValue [(CI ByteString, ByteString)])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index [(CI ByteString, ByteString)]
j) (CI ByteString
Index Headers
k,ByteString
v) [(CI ByteString, ByteString)]
kv) Maybe Int
i
      in
        Maybe ByteString -> [(CI ByteString, ByteString)]
g (Maybe ByteString -> [(CI ByteString, ByteString)])
-> f (Maybe ByteString) -> f [(CI ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString -> f (Maybe ByteString)
f (CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
Index Headers
k [(CI ByteString, ByteString)]
kv)


-- | Target all values of the given header
header :: HasHeaders a => CI B.ByteString -> Traversal' a B.ByteString
header :: CI ByteString -> Traversal' a ByteString
header CI ByteString
k = ([(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)])
-> a -> f a
forall a. HasHeaders a => Lens' a [(CI ByteString, ByteString)]
headerList (([(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)])
 -> a -> f a)
-> ((ByteString -> f ByteString)
    -> [(CI ByteString, ByteString)]
    -> f [(CI ByteString, ByteString)])
-> (ByteString -> f ByteString)
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> f (CI ByteString, ByteString))
-> [(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed (((CI ByteString, ByteString) -> f (CI ByteString, ByteString))
 -> [(CI ByteString, ByteString)]
 -> f [(CI ByteString, ByteString)])
-> ((ByteString -> f ByteString)
    -> (CI ByteString, ByteString) -> f (CI ByteString, ByteString))
-> (ByteString -> f ByteString)
-> [(CI ByteString, ByteString)]
-> f [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString) -> Bool)
-> Optic'
     (->) f (CI ByteString, ByteString) (CI ByteString, ByteString)
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered ((CI ByteString
k CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (CI ByteString -> Bool)
-> ((CI ByteString, ByteString) -> CI ByteString)
-> (CI ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI ByteString, ByteString) -> CI ByteString
forall a b. (a, b) -> a
fst) Optic'
  (->) f (CI ByteString, ByteString) (CI ByteString, ByteString)
-> ((ByteString -> f ByteString)
    -> (CI ByteString, ByteString) -> f (CI ByteString, ByteString))
-> (ByteString -> f ByteString)
-> (CI ByteString, ByteString)
-> f (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> f ByteString)
-> (CI ByteString, ByteString) -> f (CI ByteString, ByteString)
forall s t a b. Field2 s t a b => Lens s t a b
_2

-- | Message type, parameterised over context and body type.  The
-- context type is not used in this module but is provided for uses
-- such as tracking the transfer/charset encoding state in MIME
-- messages.
--
data Message s a = Message Headers a
  deriving (Int -> Message s a -> ShowS
[Message s a] -> ShowS
Message s a -> String
(Int -> Message s a -> ShowS)
-> (Message s a -> String)
-> ([Message s a] -> ShowS)
-> Show (Message s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s a. Show a => Int -> Message s a -> ShowS
forall s a. Show a => [Message s a] -> ShowS
forall s a. Show a => Message s a -> String
showList :: [Message s a] -> ShowS
$cshowList :: forall s a. Show a => [Message s a] -> ShowS
show :: Message s a -> String
$cshow :: forall s a. Show a => Message s a -> String
showsPrec :: Int -> Message s a -> ShowS
$cshowsPrec :: forall s a. Show a => Int -> Message s a -> ShowS
Show, (forall x. Message s a -> Rep (Message s a) x)
-> (forall x. Rep (Message s a) x -> Message s a)
-> Generic (Message s a)
forall x. Rep (Message s a) x -> Message s a
forall x. Message s a -> Rep (Message s a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s a x. Rep (Message s a) x -> Message s a
forall s a x. Message s a -> Rep (Message s a) x
$cto :: forall s a x. Rep (Message s a) x -> Message s a
$cfrom :: forall s a x. Message s a -> Rep (Message s a) x
Generic, Message s a -> ()
(Message s a -> ()) -> NFData (Message s a)
forall a. (a -> ()) -> NFData a
forall s a. NFData a => Message s a -> ()
rnf :: Message s a -> ()
$crnf :: forall s a. NFData a => Message s a -> ()
NFData)

instance HasHeaders (Message s a) where
  headers :: (Headers -> f Headers) -> Message s a -> f (Message s a)
headers Headers -> f Headers
f (Message Headers
h a
b) = (Headers -> Message s a) -> f Headers -> f (Message s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Headers -> a -> Message s a
forall s a. Headers -> a -> Message s a
`Message` a
b) (Headers -> f Headers
f Headers
h)

instance Functor (Message s) where
  fmap :: (a -> b) -> Message s a -> Message s b
fmap a -> b
f (Message Headers
h a
a) = Headers -> b -> Message s b
forall s a. Headers -> a -> Message s a
Message Headers
h (a -> b
f a
a)

-- | How to compare messages with this body type.
--
-- This class arises because we may want to tweak the headers,
-- possibly in response to body data, or vice-versa, when
-- comparing messages.
--
-- The default implementation compares headers and body using (==).
--
class EqMessage a where
  eqMessage :: Message s a -> Message s a -> Bool

  default eqMessage :: (Eq a) => Message s a -> Message s a -> Bool
  eqMessage (Message Headers
h1 a
b1) (Message Headers
h2 a
b2) = Headers
h1 Headers -> Headers -> Bool
forall a. Eq a => a -> a -> Bool
== Headers
h2 Bool -> Bool -> Bool
&& a
b1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b2


instance EqMessage a => Eq (Message s a) where
  == :: Message s a -> Message s a -> Bool
(==) = Message s a -> Message s a -> Bool
forall a s. EqMessage a => Message s a -> Message s a -> Bool
eqMessage

-- | Access headers as a list of key/value pairs.
headerList :: HasHeaders a => Lens' a [(CI B.ByteString, B.ByteString)]
headerList :: Lens' a [(CI ByteString, ByteString)]
headerList = (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> (([(CI ByteString, ByteString)]
     -> f [(CI ByteString, ByteString)])
    -> Headers -> f Headers)
-> ([(CI ByteString, ByteString)]
    -> f [(CI ByteString, ByteString)])
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(CI ByteString, ByteString)] -> f [(CI ByteString, ByteString)])
-> Headers -> f Headers
forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b
coerced

body :: Lens (Message ctx a) (Message ctx' b) a b
body :: (a -> f b) -> Message ctx a -> f (Message ctx' b)
body a -> f b
f (Message Headers
h a
b) = (b -> Message ctx' b) -> f b -> f (Message ctx' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
b' -> Headers -> b -> Message ctx' b
forall s a. Headers -> a -> Message s a
Message Headers
h b
b') (a -> f b
f a
b)
{-# ANN body ("HLint: ignore Avoid lambda" :: String) #-}


-- §3.3  Date and Time Specification
-- Sat, 29 Sep 2018 12:51:05 +1000
rfc5322DateTimeFormat :: String
rfc5322DateTimeFormat :: String
rfc5322DateTimeFormat = String
"%a, %d %b %Y %T %z"

renderRFC5322Date :: ZonedTime -> B.ByteString
renderRFC5322Date :: ZonedTime -> ByteString
renderRFC5322Date = String -> ByteString
Char8.pack (String -> ByteString)
-> (ZonedTime -> String) -> ZonedTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
rfc5322DateTimeFormat

headerDate :: HasHeaders a => Lens' a (Maybe ZonedTime)
headerDate :: Lens' a (Maybe ZonedTime)
headerDate = (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> ((Maybe ZonedTime -> f (Maybe ZonedTime))
    -> Headers -> f Headers)
-> (Maybe ZonedTime -> f (Maybe ZonedTime))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Headers
"Date" ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> ((Maybe ZonedTime -> f (Maybe ZonedTime))
    -> Maybe ByteString -> f (Maybe ByteString))
-> (Maybe ZonedTime -> f (Maybe ZonedTime))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> Maybe ZonedTime)
-> (Maybe ZonedTime -> Maybe ByteString)
-> Iso
     (Maybe ByteString)
     (Maybe ByteString)
     (Maybe ZonedTime)
     (Maybe ZonedTime)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (Maybe ByteString
-> (ByteString -> Maybe ZonedTime) -> Maybe ZonedTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe ZonedTime
p) ((ZonedTime -> ByteString) -> Maybe ZonedTime -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ZonedTime -> ByteString
renderRFC5322Date)
  where
  p :: ByteString -> Maybe ZonedTime
p = (String -> Maybe ZonedTime)
-> (ZonedTime -> Maybe ZonedTime)
-> Either String ZonedTime
-> Maybe ZonedTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ZonedTime -> String -> Maybe ZonedTime
forall a b. a -> b -> a
const Maybe ZonedTime
forall a. Maybe a
Nothing) ZonedTime -> Maybe ZonedTime
forall a. a -> Maybe a
Just (Either String ZonedTime -> Maybe ZonedTime)
-> (ByteString -> Either String ZonedTime)
-> ByteString
-> Maybe ZonedTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ZonedTime -> ByteString -> Either String ZonedTime
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser ZonedTime
dateTime Parser ZonedTime -> Parser ByteString () -> Parser ZonedTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput)

-- §3.4 Address Specification
buildMailbox :: Mailbox -> Builder.Builder
buildMailbox :: Mailbox -> Builder
buildMailbox (Mailbox Maybe Text
n AddrSpec
a) =
  Builder -> (Text -> Builder) -> Maybe Text -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
a' (\Text
n' -> Text -> Builder
buildPhrase Text
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" <" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
a' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">") Maybe Text
n
  where
    a' :: Builder
a' = AddrSpec -> Builder
buildAddressSpec AddrSpec
a

-- Encode a phrase.
--
-- * Empty string is special case; must be in quotes
-- * If valid as an atom, use as-is (ideally, but we don't do this yet)
-- * If it can be in a quoted-string, do so.
-- * Otherwise make it an encoded-word
--
buildPhrase :: T.Text -> Builder.Builder
buildPhrase :: Text -> Builder
buildPhrase Text
"" = Builder
"\"\""
buildPhrase Text
s =
  case Text -> PhraseEscapeRequirement
enc Text
s of
    PhraseEscapeRequirement
PhraseAtom -> Text -> Builder
T.encodeUtf8Builder Text
s
    PhraseEscapeRequirement
PhraseQuotedString -> Bool -> Builder
qsBuilder Bool
False
    PhraseEscapeRequirement
PhraseQuotedStringEscapeSpace -> Bool -> Builder
qsBuilder Bool
True
    PhraseEscapeRequirement
PhraseEncodedWord -> EncodedWord -> Builder
buildEncodedWord (EncodedWord -> Builder)
-> (Text -> EncodedWord) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferDecodedEncodedWord -> EncodedWord
forall a. HasTransferEncoding a => TransferDecoded a -> a
transferEncode (TransferDecodedEncodedWord -> EncodedWord)
-> (Text -> TransferDecodedEncodedWord) -> Text -> EncodedWord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TransferDecodedEncodedWord
forall a. HasCharset a => Decoded a -> a
charsetEncode (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text
s
  where
    enc :: Text -> PhraseEscapeRequirement
enc = (Char, PhraseEscapeRequirement) -> PhraseEscapeRequirement
forall a b. (a, b) -> b
snd ((Char, PhraseEscapeRequirement) -> PhraseEscapeRequirement)
-> (Text -> (Char, PhraseEscapeRequirement))
-> Text
-> PhraseEscapeRequirement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
 -> (Char, PhraseEscapeRequirement)
 -> (Char, PhraseEscapeRequirement))
-> (Char, PhraseEscapeRequirement)
-> Text
-> (Char, PhraseEscapeRequirement)
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr (\Char
c (Char
prev, PhraseEscapeRequirement
req) -> (Char
c, Char -> Char -> PhraseEscapeRequirement
encChar Char
prev Char
c PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
forall a. Semigroup a => a -> a -> a
<> PhraseEscapeRequirement
req)) (Char
'\0', PhraseEscapeRequirement
forall a. Monoid a => a
mempty)
    encChar :: Char -> Char -> PhraseEscapeRequirement
encChar Char
prev Char
c
      | Char -> Bool
forall c. IsChar c => c -> Bool
isAtext Char
c = PhraseEscapeRequirement
PhraseAtom
      | Char -> Bool
forall c. IsChar c => c -> Bool
isQtext Char
c = PhraseEscapeRequirement
PhraseQuotedString
      | Char -> Bool
forall c. IsChar c => c -> Bool
isVchar Char
c = PhraseEscapeRequirement
PhraseQuotedString
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' =
          if Char
prev Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '  -- two spaces in a row; need to avoid FWS
          then PhraseEscapeRequirement
PhraseQuotedStringEscapeSpace
          else PhraseEscapeRequirement
PhraseQuotedString
      | Bool
otherwise = PhraseEscapeRequirement
PhraseEncodedWord

    qsBuilder :: Bool -> Builder
qsBuilder Bool
escSpace = Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> BoundedPrim Word8 -> Text -> Builder
T.encodeUtf8BuilderEscaped (Bool -> BoundedPrim Word8
escPrim Bool
escSpace) Text
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""
    escPrim :: Bool -> BoundedPrim Word8
escPrim Bool
escSpace = (Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
Prim.condB (\Word8
c -> Word8 -> Bool
forall c. IsChar c => c -> Bool
isQtext Word8
c Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
escSpace Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32)
      (FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
Prim.liftFixedToBounded FixedPrim Word8
Prim.word8)
      (FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
Prim.liftFixedToBounded (FixedPrim Word8 -> BoundedPrim Word8)
-> FixedPrim Word8 -> BoundedPrim Word8
forall a b. (a -> b) -> a -> b
$ (Char -> Word8
forall a. IsChar a => Char -> a
fromChar Char
'\\',) (Word8 -> (Word8, Word8))
-> FixedPrim (Word8, Word8) -> FixedPrim Word8
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
Prim.>$< FixedPrim Word8
Prim.word8 FixedPrim Word8 -> FixedPrim Word8 -> FixedPrim (Word8, Word8)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
Prim.>*< FixedPrim Word8
Prim.word8)

-- | Data type used to compute escaping requirement of a Text 'phrase'
--
data PhraseEscapeRequirement
  = PhraseAtom
  | PhraseQuotedString
  | PhraseQuotedStringEscapeSpace
  | PhraseEncodedWord
  deriving (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
(PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool)
-> (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool)
-> Eq PhraseEscapeRequirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
$c/= :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
== :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
$c== :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
Eq, Eq PhraseEscapeRequirement
Eq PhraseEscapeRequirement
-> (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Ordering)
-> (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool)
-> (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool)
-> (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool)
-> (PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool)
-> (PhraseEscapeRequirement
    -> PhraseEscapeRequirement -> PhraseEscapeRequirement)
-> (PhraseEscapeRequirement
    -> PhraseEscapeRequirement -> PhraseEscapeRequirement)
-> Ord PhraseEscapeRequirement
PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
PhraseEscapeRequirement -> PhraseEscapeRequirement -> Ordering
PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
$cmin :: PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
max :: PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
$cmax :: PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
>= :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
$c>= :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
> :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
$c> :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
<= :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
$c<= :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
< :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
$c< :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Bool
compare :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Ordering
$ccompare :: PhraseEscapeRequirement -> PhraseEscapeRequirement -> Ordering
$cp1Ord :: Eq PhraseEscapeRequirement
Ord)

instance Semigroup PhraseEscapeRequirement where
  PhraseEscapeRequirement
PhraseEncodedWord <> :: PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
<> PhraseEscapeRequirement
_ =
    -- allows early termination of folds
    PhraseEscapeRequirement
PhraseEncodedWord
  PhraseEscapeRequirement
l <> PhraseEscapeRequirement
r = PhraseEscapeRequirement
-> PhraseEscapeRequirement -> PhraseEscapeRequirement
forall a. Ord a => a -> a -> a
max PhraseEscapeRequirement
l PhraseEscapeRequirement
r

instance Monoid PhraseEscapeRequirement where
  mempty :: PhraseEscapeRequirement
mempty = PhraseEscapeRequirement
PhraseAtom



renderMailboxes :: [Mailbox] -> B.ByteString
renderMailboxes :: [Mailbox] -> ByteString
renderMailboxes = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> ([Mailbox] -> ByteString) -> [Mailbox] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> ([Mailbox] -> Builder) -> [Mailbox] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Mailbox] -> Builder
buildMailboxes

buildMailboxes :: [Mailbox] -> Builder.Builder
buildMailboxes :: [Mailbox] -> Builder
buildMailboxes = [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Builder] -> Builder)
-> ([Mailbox] -> [Builder]) -> [Mailbox] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
Data.List.intersperse Builder
", " ([Builder] -> [Builder])
-> ([Mailbox] -> [Builder]) -> [Mailbox] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Mailbox -> Builder) -> [Mailbox] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Mailbox -> Builder
buildMailbox

renderMailbox :: Mailbox -> B.ByteString
renderMailbox :: Mailbox -> ByteString
renderMailbox = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> (Mailbox -> ByteString) -> Mailbox -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (Mailbox -> Builder) -> Mailbox -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mailbox -> Builder
buildMailbox

mailbox :: CharsetLookup -> Parser Mailbox
mailbox :: CharsetLookup -> Parser Mailbox
mailbox CharsetLookup
charsets =
  Maybe Text -> AddrSpec -> Mailbox
Mailbox (Maybe Text -> AddrSpec -> Mailbox)
-> Parser ByteString (Maybe Text)
-> Parser ByteString (AddrSpec -> Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Text -> Parser ByteString (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (CharsetLookup -> Parser ByteString Text
displayName CharsetLookup
charsets) Parser ByteString (AddrSpec -> Mailbox)
-> Parser ByteString AddrSpec -> Parser Mailbox
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString AddrSpec
angleAddr
  Parser Mailbox -> Parser Mailbox -> Parser Mailbox
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text -> AddrSpec -> Mailbox
Mailbox Maybe Text
forall a. Maybe a
Nothing (AddrSpec -> Mailbox)
-> Parser ByteString AddrSpec -> Parser Mailbox
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString AddrSpec
addressSpec

phrase :: CharsetLookup -> Parser T.Text
phrase :: CharsetLookup -> Parser ByteString Text
phrase CharsetLookup
charsets = Text -> Parser ByteString Text -> Parser ByteString Text
forall m (f :: * -> *).
(Semigroup m, Alternative f) =>
m -> f m -> f m
foldMany1Sep Text
" " (Parser ByteString Text -> Parser ByteString Text)
-> Parser ByteString Text -> Parser ByteString Text
forall a b. (a -> b) -> a -> b
$
  -- RFC 2047 §2: if it is desirable to encode more text than will
  -- fit in an 'encoded-word' of 75 characters, multiple
  -- 'encoded-word's (separated by CRLF SPACE) may be used.
  --
  -- The initial header parsing unfolds the header, so such
  -- "continuation" encoded-words are now separated by SPACE.  The
  -- CRLFs have been erased.  Naïvely, this seems to make this case
  -- indistinguishable from "consecutive" encoded-words that were
  -- actually separated by SPACE.  However, a careful examination of
  -- the grammar shows that encoded-words in a 'phrase' cannot be
  -- separated by whitespace:
  --
  -- @
  -- phrase         = 1*( encoded-word / word )
  -- encoded-word   = "=?" charset "?" encoding "?" encoded-text "?="
  -- word           = atom / quoted-string
  -- atom           = [CFWS] 1*atext [CFWS]
  -- quoted-string  = [CFWS]
  --                  DQUOTE *([FWS] qcontent) [FWS] DQUOTE
  --                  [CFWS]
  -- @
  --
  -- The only place whitespace is allowed is within 'atom' and
  -- 'quoted-string'.  Therefore two encoded-words separated by
  -- SPACE must be the result of folding a long encoded-word.  So
  -- consume as many SPACE separated encoded-words as possible,
  -- decode them, and concatenate the result.
  ([EncodedWord] -> Text)
-> Parser ByteString [EncodedWord] -> Parser ByteString Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( (EncodedWord -> Text) -> [EncodedWord] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CharsetLookup -> EncodedWord -> Text
decodeEncodedWord CharsetLookup
charsets) )
    ( (Parser ByteString ByteString
"=?" Parser ByteString ByteString
-> Parser ByteString EncodedWord -> Parser ByteString EncodedWord
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString EncodedWord
encodedWord) Parser ByteString EncodedWord
-> Parser ByteString Word8 -> Parser ByteString [EncodedWord]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser ByteString Word8
char8 Char
' ' )
  Parser ByteString Text
-> Parser ByteString Text -> Parser ByteString Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Text)
-> Parser ByteString ByteString -> Parser ByteString Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeLenient Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
word

displayName :: CharsetLookup -> Parser T.Text
displayName :: CharsetLookup -> Parser ByteString Text
displayName = CharsetLookup -> Parser ByteString Text
phrase

angleAddr :: Parser AddrSpec
angleAddr :: Parser ByteString AddrSpec
angleAddr = Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS Parser ByteString ByteString
-> Parser ByteString Word8 -> Parser ByteString Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
  Char -> Parser ByteString Word8
char8 Char
'<' Parser ByteString Word8
-> Parser ByteString AddrSpec -> Parser ByteString AddrSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString AddrSpec
addressSpec Parser ByteString AddrSpec
-> Parser ByteString Word8 -> Parser ByteString AddrSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Word8
char8 Char
'>'
  Parser ByteString AddrSpec
-> Parser ByteString ByteString -> Parser ByteString AddrSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS

buildAddressSpec :: AddrSpec -> Builder.Builder
buildAddressSpec :: AddrSpec -> Builder
buildAddressSpec (AddrSpec ByteString
lp (DomainDotAtom NonEmpty (CI ByteString)
b))
  | ByteString
" " ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
lp = Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
buildLP Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
rest
  | Bool
otherwise = Builder
buildLP Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
rest
  where
    buildLP :: Builder
buildLP = ByteString -> Builder
Builder.byteString ByteString
lp
    rest :: Builder
rest = Builder
"@" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (CI ByteString -> Builder) -> NonEmpty (CI ByteString) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString -> Builder
Builder.byteString (ByteString -> Builder)
-> (CI ByteString -> ByteString) -> CI ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
original)
                          (CI ByteString
-> NonEmpty (CI ByteString) -> NonEmpty (CI ByteString)
forall a. a -> NonEmpty a -> NonEmpty a
Data.List.NonEmpty.intersperse CI ByteString
"." NonEmpty (CI ByteString)
b)
buildAddressSpec (AddrSpec ByteString
lp (DomainLiteral ByteString
b)) =
  (ByteString -> Builder) -> [ByteString] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> Builder
Builder.byteString [ByteString
lp, ByteString
"@", ByteString
b]

renderAddressSpec :: AddrSpec -> B.ByteString
renderAddressSpec :: AddrSpec -> ByteString
renderAddressSpec = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> (AddrSpec -> ByteString) -> AddrSpec -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (AddrSpec -> Builder) -> AddrSpec -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrSpec -> Builder
buildAddressSpec

addressSpec :: Parser AddrSpec
addressSpec :: Parser ByteString AddrSpec
addressSpec = ByteString -> Domain -> AddrSpec
AddrSpec (ByteString -> Domain -> AddrSpec)
-> Parser ByteString ByteString
-> Parser ByteString (Domain -> AddrSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
localPart Parser ByteString (Domain -> AddrSpec)
-> Parser ByteString Domain -> Parser ByteString AddrSpec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Parser ByteString Word8
char8 Char
'@' Parser ByteString Word8
-> Parser ByteString Domain -> Parser ByteString Domain
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Domain
domain)

-- | Printable US-ASCII excl "[", "]", or "\"
isDtext :: Word8 -> Bool
isDtext :: Word8 -> Bool
isDtext 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
90) Bool -> Bool -> Bool
|| (Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
94 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
126)

domain :: Parser Domain
domain :: Parser ByteString Domain
domain = (NonEmpty (CI ByteString) -> Domain
DomainDotAtom (NonEmpty (CI ByteString) -> Domain)
-> (NonEmpty ByteString -> NonEmpty (CI ByteString))
-> NonEmpty ByteString
-> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> CI ByteString)
-> NonEmpty ByteString -> NonEmpty (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (NonEmpty ByteString -> Domain)
-> Parser ByteString (NonEmpty ByteString)
-> Parser ByteString Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (NonEmpty ByteString)
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s (NonEmpty s)
dotAtom)
         Parser ByteString Domain
-> Parser ByteString Domain -> Parser ByteString Domain
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Domain
DomainLiteral (ByteString -> Domain)
-> Parser ByteString ByteString -> Parser ByteString Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
domainLiteral)

mailboxList :: CharsetLookup -> Parser [Mailbox]
mailboxList :: CharsetLookup -> Parser [Mailbox]
mailboxList CharsetLookup
charsets = CharsetLookup -> Parser Mailbox
mailbox CharsetLookup
charsets Parser Mailbox -> Parser ByteString Word8 -> Parser [Mailbox]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser ByteString Word8
char8 Char
','

renderAddresses :: [Address] -> B.ByteString
renderAddresses :: [Address] -> ByteString
renderAddresses [Address]
xs = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
", " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Address -> ByteString
renderAddress (Address -> ByteString) -> [Address] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Address]
xs

renderAddress :: Address -> B.ByteString
renderAddress :: Address -> ByteString
renderAddress (Single Mailbox
m) = Mailbox -> ByteString
renderMailbox Mailbox
m
renderAddress (Group Text
name [Mailbox]
xs) = Text -> ByteString
T.encodeUtf8 Text
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Mailbox] -> ByteString
renderMailboxes [Mailbox]
xs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
";"

addressList :: CharsetLookup -> Parser [Address]
addressList :: CharsetLookup -> Parser [Address]
addressList CharsetLookup
charsets = CharsetLookup -> Parser Address
address CharsetLookup
charsets Parser Address -> Parser ByteString Word8 -> Parser [Address]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser ByteString Word8
char8 Char
','

group :: CharsetLookup -> Parser Address
group :: CharsetLookup -> Parser Address
group CharsetLookup
charsets =
  Text -> [Mailbox] -> Address
Group (Text -> [Mailbox] -> Address)
-> Parser ByteString Text
-> Parser ByteString ([Mailbox] -> Address)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharsetLookup -> Parser ByteString Text
displayName CharsetLookup
charsets Parser ByteString ([Mailbox] -> Address)
-> Parser ByteString Word8
-> Parser ByteString ([Mailbox] -> Address)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Word8
char8 Char
':'
        Parser ByteString ([Mailbox] -> Address)
-> Parser [Mailbox] -> Parser Address
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CharsetLookup -> Parser [Mailbox]
mailboxList CharsetLookup
charsets Parser Address -> Parser ByteString Word8 -> Parser Address
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Word8
char8 Char
';' Parser Address -> Parser ByteString ByteString -> Parser Address
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS

address :: CharsetLookup -> Parser Address
address :: CharsetLookup -> Parser Address
address CharsetLookup
charsets =
  CharsetLookup -> Parser Address
group CharsetLookup
charsets Parser Address -> Parser Address -> Parser Address
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mailbox -> Address
Single (Mailbox -> Address) -> Parser Mailbox -> Parser Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharsetLookup -> Parser Mailbox
mailbox CharsetLookup
charsets

-- | Map a single-occurrence header to a list value.
-- On read, absent header is mapped to empty list.
-- On write, empty list results in absent header.
--
headerSingleToList
  :: (HasHeaders s)
  => (B.ByteString -> [a])
  -> ([a] -> B.ByteString)
  -> CI B.ByteString
  -> Lens' s [a]
headerSingleToList :: (ByteString -> [a])
-> ([a] -> ByteString) -> CI ByteString -> Lens' s [a]
headerSingleToList ByteString -> [a]
f [a] -> ByteString
g CI ByteString
k =
  (Headers -> f Headers) -> s -> f s
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> s -> f s)
-> (([a] -> f [a]) -> Headers -> f Headers)
-> ([a] -> f [a])
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CI ByteString
Index Headers
k ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> (([a] -> f [a]) -> Maybe ByteString -> f (Maybe ByteString))
-> ([a] -> f [a])
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> [a])
-> ([a] -> Maybe ByteString)
-> Iso (Maybe ByteString) (Maybe ByteString) [a] [a]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ([a] -> (ByteString -> [a]) -> Maybe ByteString -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [a]
f) (\[a]
l -> if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
l then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ([a] -> ByteString
g [a]
l))

-- | Map a single-occurrence header to a Maybe value.
-- On read, absent header or parse failure maps to Nothing.
-- On write, Nothing results in absent header.
headerSingleToMaybe
  :: (HasHeaders s)
  => (B.ByteString -> Maybe a)
  -> (a -> B.ByteString)
  -> CI B.ByteString
  -> Lens' s (Maybe a)
headerSingleToMaybe :: (ByteString -> Maybe a)
-> (a -> ByteString) -> CI ByteString -> Lens' s (Maybe a)
headerSingleToMaybe ByteString -> Maybe a
f a -> ByteString
g CI ByteString
k = (Headers -> f Headers) -> s -> f s
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> s -> f s)
-> ((Maybe a -> f (Maybe a)) -> Headers -> f Headers)
-> (Maybe a -> f (Maybe a))
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CI ByteString
Index Headers
k ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> ((Maybe a -> f (Maybe a))
    -> Maybe ByteString -> f (Maybe ByteString))
-> (Maybe a -> f (Maybe a))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> Maybe a)
-> (Maybe a -> Maybe ByteString)
-> Iso (Maybe ByteString) (Maybe ByteString) (Maybe a) (Maybe a)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (Maybe ByteString -> (ByteString -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe a
f) ((a -> ByteString) -> Maybe a -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ByteString
g)

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

headerFrom, headerReplyTo, headerTo, headerCC, headerBCC
  :: (HasHeaders a)
  => CharsetLookup -> Lens' a [Address]
headerFrom :: CharsetLookup -> Lens' a [Address]
headerFrom = CI ByteString -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
CI ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList CI ByteString
"From"
headerReplyTo :: CharsetLookup -> Lens' a [Address]
headerReplyTo = CI ByteString -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
CI ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList CI ByteString
"Reply-To"
headerTo :: CharsetLookup -> Lens' a [Address]
headerTo = CI ByteString -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
CI ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList CI ByteString
"To"
headerCC :: CharsetLookup -> Lens' a [Address]
headerCC = CI ByteString -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
CI ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList CI ByteString
"Cc"
headerBCC :: CharsetLookup -> Lens' a [Address]
headerBCC = CI ByteString -> CharsetLookup -> Lens' a [Address]
forall a.
HasHeaders a =>
CI ByteString -> CharsetLookup -> Lens' a [Address]
headerAddressList CI ByteString
"Bcc"

data MessageID = MessageID
  (NonEmpty B.ByteString)
  (Either (NonEmpty B.ByteString) B.ByteString)
  deriving (MessageID -> MessageID -> Bool
(MessageID -> MessageID -> Bool)
-> (MessageID -> MessageID -> Bool) -> Eq MessageID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageID -> MessageID -> Bool
$c/= :: MessageID -> MessageID -> Bool
== :: MessageID -> MessageID -> Bool
$c== :: MessageID -> MessageID -> Bool
Eq, Eq MessageID
Eq MessageID
-> (MessageID -> MessageID -> Ordering)
-> (MessageID -> MessageID -> Bool)
-> (MessageID -> MessageID -> Bool)
-> (MessageID -> MessageID -> Bool)
-> (MessageID -> MessageID -> Bool)
-> (MessageID -> MessageID -> MessageID)
-> (MessageID -> MessageID -> MessageID)
-> Ord MessageID
MessageID -> MessageID -> Bool
MessageID -> MessageID -> Ordering
MessageID -> MessageID -> MessageID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MessageID -> MessageID -> MessageID
$cmin :: MessageID -> MessageID -> MessageID
max :: MessageID -> MessageID -> MessageID
$cmax :: MessageID -> MessageID -> MessageID
>= :: MessageID -> MessageID -> Bool
$c>= :: MessageID -> MessageID -> Bool
> :: MessageID -> MessageID -> Bool
$c> :: MessageID -> MessageID -> Bool
<= :: MessageID -> MessageID -> Bool
$c<= :: MessageID -> MessageID -> Bool
< :: MessageID -> MessageID -> Bool
$c< :: MessageID -> MessageID -> Bool
compare :: MessageID -> MessageID -> Ordering
$ccompare :: MessageID -> MessageID -> Ordering
$cp1Ord :: Eq MessageID
Ord)

instance Show MessageID where
  show :: MessageID -> String
show = ByteString -> String
Char8.unpack (ByteString -> String)
-> (MessageID -> ByteString) -> MessageID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageID -> ByteString
renderMessageID

parseMessageID :: Parser MessageID
parseMessageID :: Parser MessageID
parseMessageID =
  NonEmpty ByteString
-> Either (NonEmpty ByteString) ByteString -> MessageID
MessageID
    (NonEmpty ByteString
 -> Either (NonEmpty ByteString) ByteString -> MessageID)
-> Parser ByteString (NonEmpty ByteString)
-> Parser
     ByteString (Either (NonEmpty ByteString) ByteString -> MessageID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS Parser ByteString ByteString
-> Parser ByteString Word8 -> Parser ByteString Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'<'  Parser ByteString Word8
-> Parser ByteString (NonEmpty ByteString)
-> Parser ByteString (NonEmpty ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (NonEmpty ByteString)
idLeft) Parser
  ByteString (Either (NonEmpty ByteString) ByteString -> MessageID)
-> Parser ByteString Word8
-> Parser
     ByteString (Either (NonEmpty ByteString) ByteString -> MessageID)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'@'
    Parser
  ByteString (Either (NonEmpty ByteString) ByteString -> MessageID)
-> Parser ByteString (Either (NonEmpty ByteString) ByteString)
-> Parser MessageID
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (Either (NonEmpty ByteString) ByteString)
idRight Parser MessageID -> Parser ByteString Word8 -> Parser MessageID
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'>' Parser MessageID
-> Parser ByteString ByteString -> Parser MessageID
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS
  where
  idLeft :: Parser ByteString (NonEmpty ByteString)
idLeft = Parser ByteString (NonEmpty ByteString)
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s (NonEmpty s)
dotAtomText
  idRight :: Parser ByteString (Either (NonEmpty ByteString) ByteString)
idRight = NonEmpty ByteString -> Either (NonEmpty ByteString) ByteString
forall a b. a -> Either a b
Left (NonEmpty ByteString -> Either (NonEmpty ByteString) ByteString)
-> Parser ByteString (NonEmpty ByteString)
-> Parser ByteString (Either (NonEmpty ByteString) ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (NonEmpty ByteString)
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s (NonEmpty s)
dotAtomText Parser ByteString (Either (NonEmpty ByteString) ByteString)
-> Parser ByteString (Either (NonEmpty ByteString) ByteString)
-> Parser ByteString (Either (NonEmpty ByteString) ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Either (NonEmpty ByteString) ByteString
forall a b. b -> Either a b
Right (ByteString -> Either (NonEmpty ByteString) ByteString)
-> Parser ByteString ByteString
-> Parser ByteString (Either (NonEmpty ByteString) ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
noFoldLiteral
  noFoldLiteral :: Parser ByteString ByteString
noFoldLiteral = Char -> Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'[' Parser ByteString Word8
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Word8 -> Bool
isDtext Parser ByteString ByteString
-> Parser ByteString Word8 -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
']'

buildMessageID :: MessageID -> Builder.Builder
buildMessageID :: MessageID -> Builder
buildMessageID (MessageID NonEmpty ByteString
l Either (NonEmpty ByteString) ByteString
r) =
  Builder
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> NonEmpty ByteString -> Builder
buildDotAtom NonEmpty ByteString
l Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"@" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (NonEmpty ByteString -> Builder)
-> (ByteString -> Builder)
-> Either (NonEmpty ByteString) ByteString
-> Builder
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NonEmpty ByteString -> Builder
buildDotAtom ByteString -> Builder
buildNoFoldLit Either (NonEmpty ByteString) ByteString
r Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
  where
  buildDotAtom :: NonEmpty ByteString -> Builder
buildDotAtom =
    NonEmpty Builder -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (NonEmpty Builder -> Builder)
-> (NonEmpty ByteString -> NonEmpty Builder)
-> NonEmpty ByteString
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> NonEmpty Builder -> NonEmpty Builder
forall a. a -> NonEmpty a -> NonEmpty a
Data.List.NonEmpty.intersperse Builder
"." (NonEmpty Builder -> NonEmpty Builder)
-> (NonEmpty ByteString -> NonEmpty Builder)
-> NonEmpty ByteString
-> NonEmpty Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Builder) -> NonEmpty ByteString -> NonEmpty Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Builder
Builder.byteString
  buildNoFoldLit :: ByteString -> Builder
buildNoFoldLit ByteString
s =
    Builder
"[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"]"

renderMessageID :: MessageID -> B.ByteString
renderMessageID :: MessageID -> ByteString
renderMessageID = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> (MessageID -> ByteString) -> MessageID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (MessageID -> Builder) -> MessageID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageID -> Builder
buildMessageID

headerMessageID :: (HasHeaders a) => Lens' a (Maybe MessageID)
headerMessageID :: Lens' a (Maybe MessageID)
headerMessageID = (ByteString -> Maybe MessageID)
-> (MessageID -> ByteString)
-> CI ByteString
-> Lens' a (Maybe MessageID)
forall s a.
HasHeaders s =>
(ByteString -> Maybe a)
-> (a -> ByteString) -> CI ByteString -> Lens' s (Maybe a)
headerSingleToMaybe
  ((String -> Maybe MessageID)
-> (MessageID -> Maybe MessageID)
-> Either String MessageID
-> Maybe MessageID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe MessageID -> String -> Maybe MessageID
forall a b. a -> b -> a
const Maybe MessageID
forall a. Maybe a
Nothing) MessageID -> Maybe MessageID
forall a. a -> Maybe a
Just (Either String MessageID -> Maybe MessageID)
-> (ByteString -> Either String MessageID)
-> ByteString
-> Maybe MessageID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser MessageID -> ByteString -> Either String MessageID
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser MessageID
parseMessageID Parser MessageID -> Parser ByteString () -> Parser MessageID
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput))
  MessageID -> ByteString
renderMessageID
  CI ByteString
"Message-ID"

headerMessageIDList :: (HasHeaders a) => CI B.ByteString -> Lens' a [MessageID]
headerMessageIDList :: CI ByteString -> Lens' a [MessageID]
headerMessageIDList = (ByteString -> [MessageID])
-> ([MessageID] -> ByteString)
-> CI ByteString
-> Lens' a [MessageID]
forall s a.
HasHeaders s =>
(ByteString -> [a])
-> ([a] -> ByteString) -> CI ByteString -> Lens' s [a]
headerSingleToList
  ([MessageID] -> Either String [MessageID] -> [MessageID]
forall b a. b -> Either a b -> b
fromRight [] (Either String [MessageID] -> [MessageID])
-> (ByteString -> Either String [MessageID])
-> ByteString
-> [MessageID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [MessageID] -> ByteString -> Either String [MessageID]
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser MessageID -> Parser [MessageID]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser MessageID
parseMessageID Parser [MessageID] -> Parser ByteString () -> Parser [MessageID]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput))
  ( ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> ([MessageID] -> ByteString) -> [MessageID] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString
    (Builder -> ByteString)
-> ([MessageID] -> Builder) -> [MessageID] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Builder] -> Builder)
-> ([MessageID] -> [Builder]) -> [MessageID] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
Data.List.intersperse Builder
" " ([Builder] -> [Builder])
-> ([MessageID] -> [Builder]) -> [MessageID] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MessageID -> Builder) -> [MessageID] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MessageID -> Builder
buildMessageID )

headerInReplyTo, headerReferences :: (HasHeaders a) => Lens' a [MessageID]
headerInReplyTo :: Lens' a [MessageID]
headerInReplyTo = CI ByteString -> Lens' a [MessageID]
forall a. HasHeaders a => CI ByteString -> Lens' a [MessageID]
headerMessageIDList CI ByteString
"In-Reply-To"
headerReferences :: Lens' a [MessageID]
headerReferences = CI ByteString -> Lens' a [MessageID]
forall a. HasHeaders a => CI ByteString -> Lens' a [MessageID]
headerMessageIDList CI ByteString
"References"


-- | Single-valued header with @Text@ value via encoded-words.
-- The conversion to/from Text is total (encoded-words that failed to be
-- decoded are passed through unchanged).  Therefore @Nothing@ means that
-- the header was not present.
--
headerText :: (HasHeaders a) => CharsetLookup -> CI B.ByteString -> Lens' a (Maybe T.Text)
headerText :: CharsetLookup -> CI ByteString -> Lens' a (Maybe Text)
headerText CharsetLookup
charsets CI ByteString
k =
  (Headers -> f Headers) -> a -> f a
forall a. HasHeaders a => Lens' a Headers
headers ((Headers -> f Headers) -> a -> f a)
-> ((Maybe Text -> f (Maybe Text)) -> Headers -> f Headers)
-> (Maybe Text -> f (Maybe Text))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Headers -> Lens' Headers (Maybe (IxValue Headers))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CI ByteString
Index Headers
k ((Maybe ByteString -> f (Maybe ByteString))
 -> Headers -> f Headers)
-> ((Maybe Text -> f (Maybe Text))
    -> Maybe ByteString -> f (Maybe ByteString))
-> (Maybe Text -> f (Maybe Text))
-> Headers
-> f Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> Maybe Text)
-> (Maybe Text -> Maybe ByteString)
-> Iso
     (Maybe ByteString) (Maybe ByteString) (Maybe Text) (Maybe Text)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CharsetLookup -> ByteString -> Text
decodeEncodedWords CharsetLookup
charsets)) ((Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeEncodedWords)

-- | Subject header.  See 'headerText' for details of conversion to @Text@.
headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)
headerSubject :: CharsetLookup -> Lens' a (Maybe Text)
headerSubject CharsetLookup
charsets = CharsetLookup -> CI ByteString -> Lens' a (Maybe Text)
forall a.
HasHeaders a =>
CharsetLookup -> CI ByteString -> Lens' a (Maybe Text)
headerText CharsetLookup
charsets CI ByteString
"Subject"


{- Replying -}

-- | Specify how to choose recipients when replying.
--
-- __TODO__: "list reply" mode
--
data ReplyMode
  = ReplyToSender
  -- ^ Reply to the sender of the email only, or @Reply-To@ header if set.
  | ReplyToGroup
  -- ^ Reply to sender and @Cc@ all other recipients of the original message.

-- | The mailboxes of the entity authoring the reply.
-- The first mailbox is the "preferred" mailbox.
type AuthorMailboxes = NonEmpty Mailbox

-- | How to choose the @From@ address.
data ReplyFromMode
  = ReplyFromPreferredMailbox
  -- ^ Always reply @From@ the preferred mailbox
  | ReplyFromMatchingMailbox
  -- ^ Reply from whichever author mailbox is a recipient of the
  -- parent message, or the preferred mailbox if none of the author
  -- mailboxes is a visible recipient of the parent message.

-- | Whether to use the @From@ address as it appears in the parent
-- message, or as it appears in the 'AuthorMailboxes'.
--
data ReplyFromRewriteMode
  = ReplyFromRewriteOff
  -- ^ Use the @From@ mailbox as it appears in the original message.
  | ReplyFromRewriteOn
  -- ^ Use the @From@ mailbox as it appears in the author mailboxes.

data SelfInRecipientsMode
  = SelfInRecipientsRemove
  -- ^ Remove author mailbox from list of recipients when replying.
  | SelfInRecipientsIgnore
  -- ^ If author mailbox appears in list of recipients, leave it there.

-- | All the settings to control how to construct a reply to a message.
data ReplySettings = ReplySettings
  { ReplySettings -> ReplyMode
_replyMode            :: ReplyMode
  , ReplySettings -> ReplyFromMode
_replyFromMode        :: ReplyFromMode
  , ReplySettings -> ReplyFromRewriteMode
_replyFromRewriteMode :: ReplyFromRewriteMode
  , ReplySettings -> SelfInRecipientsMode
_selfInRecipientsMode :: SelfInRecipientsMode
  , ReplySettings -> AuthorMailboxes
_authorMailboxes      :: AuthorMailboxes
  }

-- | Given author mailboxes, get a default 'ReplySettings'.  The default
-- settings are: 'ReplyToSender', 'ReplyFromMatchingMailbox',
-- 'ReplyFromRewriteOn', and 'SelfInRecipientsRemove'.
--
defaultReplySettings :: AuthorMailboxes -> ReplySettings
defaultReplySettings :: AuthorMailboxes -> ReplySettings
defaultReplySettings = ReplyMode
-> ReplyFromMode
-> ReplyFromRewriteMode
-> SelfInRecipientsMode
-> AuthorMailboxes
-> ReplySettings
ReplySettings
  ReplyMode
ReplyToSender
  ReplyFromMode
ReplyFromMatchingMailbox
  ReplyFromRewriteMode
ReplyFromRewriteOn
  SelfInRecipientsMode
SelfInRecipientsRemove

replyMode :: Lens' ReplySettings ReplyMode
replyMode :: (ReplyMode -> f ReplyMode) -> ReplySettings -> f ReplySettings
replyMode = (ReplySettings -> ReplyMode)
-> (ReplySettings -> ReplyMode -> ReplySettings)
-> Lens ReplySettings ReplySettings ReplyMode ReplyMode
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ReplySettings -> ReplyMode
_replyMode (\ReplySettings
s ReplyMode
a -> ReplySettings
s { _replyMode :: ReplyMode
_replyMode = ReplyMode
a })

replyFromMode :: Lens' ReplySettings ReplyFromMode
replyFromMode :: (ReplyFromMode -> f ReplyFromMode)
-> ReplySettings -> f ReplySettings
replyFromMode = (ReplySettings -> ReplyFromMode)
-> (ReplySettings -> ReplyFromMode -> ReplySettings)
-> Lens ReplySettings ReplySettings ReplyFromMode ReplyFromMode
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ReplySettings -> ReplyFromMode
_replyFromMode (\ReplySettings
s ReplyFromMode
a -> ReplySettings
s { _replyFromMode :: ReplyFromMode
_replyFromMode = ReplyFromMode
a })

replyFromRewriteMode :: Lens' ReplySettings ReplyFromRewriteMode
replyFromRewriteMode :: (ReplyFromRewriteMode -> f ReplyFromRewriteMode)
-> ReplySettings -> f ReplySettings
replyFromRewriteMode =
  (ReplySettings -> ReplyFromRewriteMode)
-> (ReplySettings -> ReplyFromRewriteMode -> ReplySettings)
-> Lens
     ReplySettings
     ReplySettings
     ReplyFromRewriteMode
     ReplyFromRewriteMode
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ReplySettings -> ReplyFromRewriteMode
_replyFromRewriteMode (\ReplySettings
s ReplyFromRewriteMode
a -> ReplySettings
s { _replyFromRewriteMode :: ReplyFromRewriteMode
_replyFromRewriteMode = ReplyFromRewriteMode
a })

selfInRecipientsMode :: Lens' ReplySettings SelfInRecipientsMode
selfInRecipientsMode :: (SelfInRecipientsMode -> f SelfInRecipientsMode)
-> ReplySettings -> f ReplySettings
selfInRecipientsMode =
  (ReplySettings -> SelfInRecipientsMode)
-> (ReplySettings -> SelfInRecipientsMode -> ReplySettings)
-> Lens
     ReplySettings
     ReplySettings
     SelfInRecipientsMode
     SelfInRecipientsMode
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ReplySettings -> SelfInRecipientsMode
_selfInRecipientsMode (\ReplySettings
s SelfInRecipientsMode
a -> ReplySettings
s { _selfInRecipientsMode :: SelfInRecipientsMode
_selfInRecipientsMode = SelfInRecipientsMode
a })

authorMailboxes :: Lens' ReplySettings AuthorMailboxes
authorMailboxes :: (AuthorMailboxes -> f AuthorMailboxes)
-> ReplySettings -> f ReplySettings
authorMailboxes = (ReplySettings -> AuthorMailboxes)
-> (ReplySettings -> AuthorMailboxes -> ReplySettings)
-> Lens ReplySettings ReplySettings AuthorMailboxes AuthorMailboxes
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ReplySettings -> AuthorMailboxes
_authorMailboxes (\ReplySettings
s AuthorMailboxes
a -> ReplySettings
s { _authorMailboxes :: AuthorMailboxes
_authorMailboxes = AuthorMailboxes
a })


replyRecipients
  :: CharsetLookup -> ReplySettings -> Message ctx a -> ([Address], [Address])
replyRecipients :: CharsetLookup
-> ReplySettings -> Message ctx a -> ([Address], [Address])
replyRecipients CharsetLookup
charsets ReplySettings
settings Message ctx a
msg =
  let
    mode :: ReplyMode
mode = Getting ReplyMode ReplySettings ReplyMode
-> ReplySettings -> ReplyMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ReplyMode ReplySettings ReplyMode
Lens ReplySettings ReplySettings ReplyMode ReplyMode
replyMode ReplySettings
settings
    rt :: [Address]
rt = Getting [Address] (Message ctx a) [Address]
-> Message ctx a -> [Address]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerReplyTo CharsetLookup
charsets) Message ctx a
msg
    f :: [Address]
f = Getting [Address] (Message ctx a) [Address]
-> Message ctx a -> [Address]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerFrom CharsetLookup
charsets) Message ctx a
msg
    t :: [Address]
t = Getting [Address] (Message ctx a) [Address]
-> Message ctx a -> [Address]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerTo CharsetLookup
charsets) Message ctx a
msg
    c :: [Address]
c = Getting [Address] (Message ctx a) [Address]
-> Message ctx a -> [Address]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerCC CharsetLookup
charsets) Message ctx a
msg
  in case ReplyMode
mode of
    ReplyMode
ReplyToSender
      | Bool -> Bool
not ([Address] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Address]
rt) -> ([Address]
rt, [])
      | Bool
otherwise     -> ([Address]
f, [])
    ReplyMode
ReplyToGroup
      | [Address] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Address]
t [Address] -> [Address] -> [Address]
forall a. Semigroup a => a -> a -> a
<> [Address]
c) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
      -> CharsetLookup
-> ReplySettings -> Message ctx a -> ([Address], [Address])
forall ctx a.
CharsetLookup
-> ReplySettings -> Message ctx a -> ([Address], [Address])
replyRecipients CharsetLookup
charsets (ASetter ReplySettings ReplySettings ReplyMode ReplyMode
-> ReplyMode -> ReplySettings -> ReplySettings
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ReplySettings ReplySettings ReplyMode ReplyMode
Lens ReplySettings ReplySettings ReplyMode ReplyMode
replyMode ReplyMode
ReplyToSender ReplySettings
settings) Message ctx a
msg
      | Bool
otherwise
      -> ([Address]
f, [Address]
t [Address] -> [Address] -> [Address]
forall a. Semigroup a => a -> a -> a
<> [Address]
c)

replyReferences :: Message ctx a -> [MessageID]
replyReferences :: Message ctx a -> [MessageID]
replyReferences Message ctx a
msg
  | [MessageID] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MessageID]
refer, [MessageID] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MessageID]
inRep Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [MessageID]
inRep [MessageID] -> [MessageID] -> [MessageID]
forall a. Semigroup a => a -> a -> a
<> [MessageID]
msgId
  | Bool
otherwise                     = [MessageID]
refer [MessageID] -> [MessageID] -> [MessageID]
forall a. Semigroup a => a -> a -> a
<> [MessageID]
msgId
  where
  msgId :: [MessageID]
msgId = Maybe MessageID -> [MessageID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe MessageID -> [MessageID]) -> Maybe MessageID -> [MessageID]
forall a b. (a -> b) -> a -> b
$ Getting (Maybe MessageID) (Message ctx a) (Maybe MessageID)
-> Message ctx a -> Maybe MessageID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe MessageID) (Message ctx a) (Maybe MessageID)
forall a. HasHeaders a => Lens' a (Maybe MessageID)
headerMessageID Message ctx a
msg
  refer :: [MessageID]
refer = Getting [MessageID] (Message ctx a) [MessageID]
-> Message ctx a -> [MessageID]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [MessageID] (Message ctx a) [MessageID]
forall a. HasHeaders a => Lens' a [MessageID]
headerReferences Message ctx a
msg
  inRep :: [MessageID]
inRep = Getting [MessageID] (Message ctx a) [MessageID]
-> Message ctx a -> [MessageID]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [MessageID] (Message ctx a) [MessageID]
forall a. HasHeaders a => Lens' a [MessageID]
headerInReplyTo Message ctx a
msg

replySubject :: CharsetLookup -> Message ctx a -> T.Text
replySubject :: CharsetLookup -> Message ctx a -> Text
replySubject CharsetLookup
charsets Message ctx a
msg = if Bool
prefixed then Text
orig else Text
"Re: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
orig
  where
  orig :: Text
orig = Maybe Text -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Getting (Maybe Text) (Message ctx a) (Maybe Text)
-> Message ctx a -> Maybe Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) (Maybe Text)
forall a. HasHeaders a => CharsetLookup -> Lens' a (Maybe Text)
headerSubject CharsetLookup
charsets) Message ctx a
msg
  prefixed :: Bool
prefixed = Text -> CI Text
forall s. FoldCase s => s -> CI s
mk (Int -> Text -> Text
T.take Int
3 Text
orig) CI Text -> CI Text -> Bool
forall a. Eq a => a -> a -> Bool
== CI Text
"Re:"


-- | Construct a reply to a 'Message', according to the specified
-- 'ReplySettings' and following the requirements and suggestions of
-- RFC 5322.  In particular:
--
-- * Sets @In-Reply-To@ to the @Message-ID@ of the parent message.
--
-- * Sets the @References@ header, following the requirements in RFC
-- 5322 §3.6.4.
--
-- * Sets the @Subject@ by prepending @"Re: "@ to the parent
-- subject, unless it already has such a prefix (case-insensitive
-- match).  This is the scheme suggested in RFC 5322 §3.6.5.
--
-- * Sets the @From@ header.  If the 'ReplyFromMode' is
-- 'ReplyFromMatchingMailbox' and one of the 'authorMailboxes' is a
-- recipient of the parent message, that address will be used as the
-- @From@ address.  Also, if 'ReplyFromRewriteMode' is
-- 'ReplyFromRewriteOn', the matching value in 'authorMailboxes'
-- replaces the value from the parent message.  This can be used to
-- rewrite a bare address to one with a display name (or
-- vice-versa).  In all other cases the @From@ address will be the
-- /preferred/ (first) author mailbox.
--
-- * Sets @To@ and @Cc@ according to 'ReplyMode' and
-- 'SelfInRecipientsMode'.  These headers are described in RFC 5322
-- §3.6.3.
--
--     * In 'ReplyToSender' mode, the @To@ header of the reply will
--     contain the addresses from the @Reply-To@ header if it is
--     present, otherwise it will contain the addresses from the
--     @From@ header.
--
--     * In 'ReplyToGroup' mode, if the parent message has only one
--     recipient (across the @To@ and @Cc@ headers), the behaviour
--     is the same as 'ReplyToSender' mode (@Reply-To@ is respected).
--     If the parent message has multiple recipients, the
--     @Reply-To@ header is ignored, the @To@ header of the reply
--     will contain the addresses from the @From@ header, and the
--     @Cc@ header of the reply will contain the addresses from the
--     @To@ and @Cc@ headers.
--
--     * If the 'SelfInRecipientsMode' is 'SelfInRecipientsRemove',
--     any of the 'authorMailboxes' will be removed from the @To@
--     and @Cc@ headers.
--
reply
  :: CharsetLookup
  -> ReplySettings
  -> Message ctx a
  -> Message ctx ()
reply :: CharsetLookup -> ReplySettings -> Message ctx a -> Message ctx ()
reply CharsetLookup
charsets ReplySettings
settings Message ctx a
msg =
  let
    self :: AuthorMailboxes
self = Getting AuthorMailboxes ReplySettings AuthorMailboxes
-> ReplySettings -> AuthorMailboxes
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting AuthorMailboxes ReplySettings AuthorMailboxes
Lens ReplySettings ReplySettings AuthorMailboxes AuthorMailboxes
authorMailboxes ReplySettings
settings

    getAddrSpec :: Mailbox -> AddrSpec
    getAddrSpec :: Mailbox -> AddrSpec
getAddrSpec (Mailbox Maybe Text
_ AddrSpec
addr) = AddrSpec
addr

    -- | Find a mailbox matching the given address.  If no match is
    -- found, return @Nothing@.  If match is found, return the value
    -- from the candidates collection if 'ReplyFromRewriteOn',
    -- otherwise return the input value.
    findMatchingMailbox
      :: (Foldable t)
      => t Mailbox -> Address -> Maybe Mailbox
    findMatchingMailbox :: t Mailbox -> Address -> Maybe Mailbox
findMatchingMailbox t Mailbox
xs (Single Mailbox
addr) =
      Mailbox -> Mailbox
f (Mailbox -> Mailbox) -> Maybe Mailbox -> Maybe Mailbox
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Mailbox -> Bool) -> t Mailbox -> Maybe Mailbox
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((AddrSpec -> AddrSpec -> Bool)
-> (Mailbox -> AddrSpec) -> Mailbox -> Mailbox -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on AddrSpec -> AddrSpec -> Bool
forall a. Eq a => a -> a -> Bool
(==) Mailbox -> AddrSpec
getAddrSpec Mailbox
addr) t Mailbox
xs
      where
        f :: Mailbox -> Mailbox
f = case Getting ReplyFromRewriteMode ReplySettings ReplyFromRewriteMode
-> ReplySettings -> ReplyFromRewriteMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ReplyFromRewriteMode ReplySettings ReplyFromRewriteMode
Lens
  ReplySettings
  ReplySettings
  ReplyFromRewriteMode
  ReplyFromRewriteMode
replyFromRewriteMode ReplySettings
settings of
          ReplyFromRewriteMode
ReplyFromRewriteOn  -> Mailbox -> Mailbox
forall a. a -> a
id
          ReplyFromRewriteMode
ReplyFromRewriteOff -> Mailbox -> Mailbox -> Mailbox
forall a b. a -> b -> a
const Mailbox
addr
    findMatchingMailbox t Mailbox
_ Address
_ = Maybe Mailbox
forall a. Maybe a
Nothing

    getSelf :: Address -> Maybe Mailbox
    getSelf :: Address -> Maybe Mailbox
getSelf = AuthorMailboxes -> Address -> Maybe Mailbox
forall (t :: * -> *).
Foldable t =>
t Mailbox -> Address -> Maybe Mailbox
findMatchingMailbox AuthorMailboxes
self

    isSelf :: Address -> Bool
    isSelf :: Address -> Bool
isSelf = Maybe Mailbox -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Mailbox -> Bool)
-> (Address -> Maybe Mailbox) -> Address -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Maybe Mailbox
getSelf

    findSelf :: Maybe Mailbox
findSelf =
      let
        parentTo :: [Address]
parentTo = Getting [Address] (Message ctx a) [Address]
-> Message ctx a -> [Address]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerTo CharsetLookup
charsets) Message ctx a
msg
        parentCc :: [Address]
parentCc = Getting [Address] (Message ctx a) [Address]
-> Message ctx a -> [Address]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (CharsetLookup -> Lens' (Message ctx a) [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerCC CharsetLookup
charsets) Message ctx a
msg
      in
        First Mailbox -> Maybe Mailbox
forall a. First a -> Maybe a
getFirst (First Mailbox -> Maybe Mailbox) -> First Mailbox -> Maybe Mailbox
forall a b. (a -> b) -> a -> b
$ (Address -> First Mailbox) -> [Address] -> First Mailbox
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Mailbox -> First Mailbox
forall a. Maybe a -> First a
First (Maybe Mailbox -> First Mailbox)
-> (Address -> Maybe Mailbox) -> Address -> First Mailbox
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Maybe Mailbox
getSelf) ([Address]
parentTo [Address] -> [Address] -> [Address]
forall a. Semigroup a => a -> a -> a
<> [Address]
parentCc)

    filterSelf :: [Address] -> [Address]
filterSelf = case Getting SelfInRecipientsMode ReplySettings SelfInRecipientsMode
-> ReplySettings -> SelfInRecipientsMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SelfInRecipientsMode ReplySettings SelfInRecipientsMode
Lens
  ReplySettings
  ReplySettings
  SelfInRecipientsMode
  SelfInRecipientsMode
selfInRecipientsMode ReplySettings
settings of
      SelfInRecipientsMode
SelfInRecipientsRemove -> (Address -> Bool) -> [Address] -> [Address]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Address -> Bool) -> Address -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Bool
isSelf)
      SelfInRecipientsMode
SelfInRecipientsIgnore -> [Address] -> [Address]
forall a. a -> a
id

    ([Address]
t, [Address]
c) = CharsetLookup
-> ReplySettings -> Message ctx a -> ([Address], [Address])
forall ctx a.
CharsetLookup
-> ReplySettings -> Message ctx a -> ([Address], [Address])
replyRecipients CharsetLookup
charsets ReplySettings
settings Message ctx a
msg
    _To :: [Address]
_To = [Address] -> [Address]
filterSelf [Address]
t
    _To_mailboxes :: [Mailbox]
_To_mailboxes = (Address -> Maybe Mailbox) -> [Address] -> [Mailbox]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case Single Mailbox
a -> Mailbox -> Maybe Mailbox
forall a. a -> Maybe a
Just Mailbox
a ; Address
_ -> Maybe Mailbox
forall a. Maybe a
Nothing) [Address]
_To
    _Cc :: [Address]
_Cc = [Address]
c
          [Address] -> ([Address] -> [Address]) -> [Address]
forall a b. a -> (a -> b) -> b
& [Address] -> [Address]
filterSelf
          [Address] -> ([Address] -> [Address]) -> [Address]
forall a b. a -> (a -> b) -> b
& (Address -> Bool) -> [Address] -> [Address]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Mailbox -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Mailbox -> Bool)
-> (Address -> Maybe Mailbox) -> Address -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Mailbox] -> Address -> Maybe Mailbox
forall (t :: * -> *).
Foldable t =>
t Mailbox -> Address -> Maybe Mailbox
findMatchingMailbox [Mailbox]
_To_mailboxes)
    _From :: Mailbox
_From =
      let preferred :: Mailbox
preferred = AuthorMailboxes -> Mailbox
forall a. NonEmpty a -> a
Data.List.NonEmpty.head AuthorMailboxes
self
      in
        case Getting ReplyFromMode ReplySettings ReplyFromMode
-> ReplySettings -> ReplyFromMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ReplyFromMode ReplySettings ReplyFromMode
Lens ReplySettings ReplySettings ReplyFromMode ReplyFromMode
replyFromMode ReplySettings
settings of
          ReplyFromMode
ReplyFromPreferredMailbox -> Mailbox
preferred
          ReplyFromMode
ReplyFromMatchingMailbox  -> Mailbox -> Maybe Mailbox -> Mailbox
forall a. a -> Maybe a -> a
fromMaybe Mailbox
preferred Maybe Mailbox
findSelf

    hdrs :: Headers
hdrs = [(CI ByteString, ByteString)] -> Headers
Headers []
      Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter Headers Headers [Address] [Address]
-> [Address] -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (CharsetLookup -> Lens' Headers [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerFrom CharsetLookup
charsets) [Mailbox -> Address
Single Mailbox
_From]
      Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter Headers Headers [Address] [Address]
-> [Address] -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (CharsetLookup -> Lens' Headers [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerTo CharsetLookup
charsets) ([Address] -> [Address]
filterSelf [Address]
_To)
      Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter Headers Headers [Address] [Address]
-> [Address] -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (CharsetLookup -> Lens' Headers [Address]
forall a. HasHeaders a => CharsetLookup -> Lens' a [Address]
headerCC CharsetLookup
charsets) ([Address] -> [Address]
filterSelf [Address]
_Cc)
      Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter Headers Headers [MessageID] [MessageID]
-> [MessageID] -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Headers Headers [MessageID] [MessageID]
forall a. HasHeaders a => Lens' a [MessageID]
headerInReplyTo (Maybe MessageID -> [MessageID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe MessageID -> [MessageID]) -> Maybe MessageID -> [MessageID]
forall a b. (a -> b) -> a -> b
$ Getting (Maybe MessageID) (Message ctx a) (Maybe MessageID)
-> Message ctx a -> Maybe MessageID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe MessageID) (Message ctx a) (Maybe MessageID)
forall a. HasHeaders a => Lens' a (Maybe MessageID)
headerMessageID Message ctx a
msg)
      Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter Headers Headers [MessageID] [MessageID]
-> [MessageID] -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Headers Headers [MessageID] [MessageID]
forall a. HasHeaders a => Lens' a [MessageID]
headerReferences (Message ctx a -> [MessageID]
forall ctx a. Message ctx a -> [MessageID]
replyReferences Message ctx a
msg)
      Headers -> (Headers -> Headers) -> Headers
forall a b. a -> (a -> b) -> b
& ASetter Headers Headers (Maybe Text) (Maybe Text)
-> Maybe Text -> Headers -> Headers
forall s t a b. ASetter s t a b -> b -> s -> t
set (CharsetLookup -> Lens' Headers (Maybe Text)
forall a. HasHeaders a => CharsetLookup -> Lens' a (Maybe Text)
headerSubject CharsetLookup
charsets) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ CharsetLookup -> Message ctx a -> Text
forall ctx a. CharsetLookup -> Message ctx a -> Text
replySubject CharsetLookup
charsets Message ctx a
msg)
  in
    Headers -> () -> Message ctx ()
forall s a. Headers -> a -> Message s a
Message Headers
hdrs ()


-- §3.5.  Overall Message Syntax


-- | Specify how to handle a message body, including the possibility
-- of optional bodies and no body (which is distinct from empty body).
data BodyHandler a
  = RequiredBody (Parser a)
  | OptionalBody (Parser a, a)
  -- ^ If body is present run parser, otherwise use constant value
  | NoBody a

-- | Parse a message.  The function argument receives the headers and
-- yields a handler for the message body.
--
message :: (Headers -> BodyHandler a) -> Parser (Message (MessageContext a) a)
message :: (Headers -> BodyHandler a) -> Parser (Message (MessageContext a) a)
message Headers -> BodyHandler a
f = Parser Headers
fields Parser Headers
-> (Headers -> Parser (Message (MessageContext a) a))
-> Parser (Message (MessageContext a) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Headers
hdrs -> Headers -> a -> Message (MessageContext a) a
forall s a. Headers -> a -> Message s a
Message Headers
hdrs (a -> Message (MessageContext a) a)
-> Parser ByteString a -> Parser (Message (MessageContext a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Headers -> BodyHandler a
f Headers
hdrs of
  RequiredBody Parser ByteString a
b -> Parser ByteString ()
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf Parser ByteString () -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString a
b
  OptionalBody (Parser ByteString a
b, a
a) -> Parser ByteString () -> Parser ByteString (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString ()
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf Parser ByteString (Maybe ())
-> (Maybe () -> Parser ByteString a) -> Parser ByteString a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser ByteString a
-> (() -> Parser ByteString a) -> Maybe () -> Parser ByteString a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (Parser ByteString a -> () -> Parser ByteString a
forall a b. a -> b -> a
const Parser ByteString a
b)
  NoBody a
b -> a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b

type family MessageContext a


fields :: Parser Headers
fields :: Parser Headers
fields = [(CI ByteString, ByteString)] -> Headers
Headers ([(CI ByteString, ByteString)] -> Headers)
-> Parser ByteString [(CI ByteString, ByteString)]
-> Parser Headers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (CI ByteString, ByteString)
-> Parser ByteString [(CI ByteString, ByteString)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString (CI ByteString, ByteString)
field

-- | Define how to render an RFC 5322 message with given payload type.
--
class RenderMessage a where
  -- | Build the body.  If there should be no body (as distinct from
  -- /empty body/) return Nothing
  buildBody :: Headers -> a -> Maybe Builder.Builder

  -- | Allows tweaking the headers before rendering.  Default
  -- implementation is a no-op.
  tweakHeaders :: a -> Headers -> Headers
  tweakHeaders a
_ = Headers -> Headers
forall a. a -> a
id

-- | Construct a 'Builder.Builder' for the message.  This allows efficient
-- streaming to IO handles.
--
buildMessage :: forall ctx a. (RenderMessage a) => Message ctx a -> Builder.Builder
buildMessage :: Message ctx a -> Builder
buildMessage (Message Headers
h a
b) =
  Headers -> Builder
buildFields (a -> Headers -> Headers
forall a. RenderMessage a => a -> Headers -> Headers
tweakHeaders a
b Headers
h)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> (Builder -> Builder) -> Maybe Builder -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (Builder
"\r\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Headers -> a -> Maybe Builder
forall a. RenderMessage a => Headers -> a -> Maybe Builder
buildBody Headers
h a
b)

-- | Render a message to a lazy 'L.ByteString'.  (You will probably not
-- need a strict @ByteString@ and it is inefficient for most use cases.)
--
renderMessage :: (RenderMessage a) => Message ctx a -> L.ByteString
renderMessage :: Message ctx a -> ByteString
renderMessage = Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (Message ctx a -> Builder) -> Message ctx a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message ctx a -> Builder
forall ctx a. RenderMessage a => Message ctx a -> Builder
buildMessage

-- Header serialisation
buildFields :: Headers -> Builder.Builder
buildFields :: Headers -> Builder
buildFields = Getting Builder Headers (CI ByteString, ByteString)
-> ((CI ByteString, ByteString) -> Builder) -> Headers -> Builder
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf (([(CI ByteString, ByteString)]
 -> Const Builder [(CI ByteString, ByteString)])
-> Headers -> Const Builder Headers
Iso
  Headers
  Headers
  [(CI ByteString, ByteString)]
  [(CI ByteString, ByteString)]
hdriso (([(CI ByteString, ByteString)]
  -> Const Builder [(CI ByteString, ByteString)])
 -> Headers -> Const Builder Headers)
-> (((CI ByteString, ByteString)
     -> Const Builder (CI ByteString, ByteString))
    -> [(CI ByteString, ByteString)]
    -> Const Builder [(CI ByteString, ByteString)])
-> Getting Builder Headers (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI ByteString, ByteString)
 -> Const Builder (CI ByteString, ByteString))
-> [(CI ByteString, ByteString)]
-> Const Builder [(CI ByteString, ByteString)]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed) (CI ByteString, ByteString) -> Builder
buildField

buildField :: (CI B.ByteString, B.ByteString) -> Builder.Builder
buildField :: (CI ByteString, ByteString) -> Builder
buildField (CI ByteString
k,ByteString
v) =
  let key :: ByteString
key = CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
k
  in
    ByteString -> Builder
Builder.byteString ByteString
key
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Int -> Builder
foldUnstructured ByteString
v (ByteString -> Int
B.length ByteString
key Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n"

-- | Render a field body with proper folding
--
-- Folds on whitespace (and only whitespace).  Sequential whitespace
-- chars are folded.  That's OK because the grammar says it is
-- folding whitespace.
--
foldUnstructured :: B.ByteString -> Int -> Builder.Builder
foldUnstructured :: ByteString -> Int -> Builder
foldUnstructured ByteString
s Int
i = case ByteString -> [ByteString]
Char8.words ByteString
s of
  [] -> Builder
forall a. Monoid a => a
mempty
  (ByteString
h:[ByteString]
t) ->
    -- Special case to prevent wrapping of first word;
    -- see 6dbc04fb1863e845699b1cef50f4edaf1326bdae for info.
    Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Int -> Builder
go [ByteString]
t (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
h)
  where
  limit :: Int
limit = Int
76  -- could be 78, but this preserves old behaviour
  go :: [ByteString] -> Int -> Builder
go [] Int
_ = Builder
forall a. Monoid a => a
mempty
  go (ByteString
chunk:[ByteString]
chunks) Int
col
    | Int
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 Bool -> Bool -> Bool
|| Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
chunk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
limit =
        -- either there is room for the chunk, or we are at the
        -- beginning of a line so add it here anyway (otherwise
        -- we will add "\r\n" and recurse forever)
        Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
chunk Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Int -> Builder
go [ByteString]
chunks (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
chunk)
    | Bool
otherwise = Builder
"\r\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Int -> Builder
go (ByteString
chunkByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
chunks) Int
0  -- fold

-- | Printable ASCII excl. ':'
isFtext :: Word8 -> Bool
isFtext :: Word8 -> Bool
isFtext 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
57) Bool -> Bool -> Bool
|| (Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
59 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
126)

field :: Parser (CI B.ByteString, B.ByteString)
field :: Parser ByteString (CI ByteString, ByteString)
field = (,)
  (CI ByteString -> ByteString -> (CI ByteString, ByteString))
-> Parser ByteString (CI ByteString)
-> Parser ByteString (ByteString -> (CI ByteString, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString -> Parser ByteString (CI ByteString)
forall s. FoldCase s => Parser s -> Parser (CI s)
ci ((Word8 -> Bool) -> Parser ByteString ByteString
takeWhile1 Word8 -> Bool
isFtext)
  Parser ByteString (ByteString -> (CI ByteString, ByteString))
-> Parser ByteString Word8
-> Parser ByteString (ByteString -> (CI ByteString, ByteString))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Char -> Parser ByteString Word8
char8 Char
':' Parser ByteString (ByteString -> (CI ByteString, ByteString))
-> Parser ByteString [Word8]
-> Parser ByteString (ByteString -> (CI ByteString, ByteString))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Word8 -> Parser ByteString [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
wsp
  Parser ByteString (ByteString -> (CI ByteString, ByteString))
-> Parser ByteString ByteString
-> Parser ByteString (CI ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
unstructured Parser ByteString (CI ByteString, ByteString)
-> Parser ByteString ()
-> Parser ByteString (CI ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf

unstructured :: Parser B.ByteString
unstructured :: Parser ByteString ByteString
unstructured =
  Parser ByteString ByteString -> Parser ByteString ByteString
forall m (f :: * -> *). (Monoid m, Alternative f) => f m -> f m
foldMany (Parser ByteString ByteString
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> (Word8 -> ByteString
B.singleton (Word8 -> ByteString)
-> Parser ByteString Word8 -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
vchar))
  Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile Word8 -> Bool
forall c. IsChar c => c -> Bool
isWsp


-- | Given a parser, construct a 'Fold'
--
-- See 'parse' for discussion of performance.
--
parsed :: (Cons s s Word8 Word8) => Parser a -> Fold s a
parsed :: Parser a -> Fold s a
parsed Parser a
p = (s -> Either String a) -> Optic' (->) f s (Either String a)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Parser a -> s -> Either String a
forall s a.
Cons s s Word8 Word8 =>
Parser a -> s -> Either String a
parse Parser a
p) Optic' (->) f s (Either String a)
-> ((a -> f a) -> Either String a -> f (Either String a))
-> (a -> f a)
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> Either String a -> f (Either String a)
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded
{-# INLINE parsed #-}

-- | Construct a prism from a parser and a printer
parsePrint :: Parser a -> (a -> B.ByteString) -> Prism' B.ByteString a
parsePrint :: Parser a -> (a -> ByteString) -> Prism' ByteString a
parsePrint Parser a
fwd a -> ByteString
rev = (a -> ByteString) -> (ByteString -> Maybe a) -> Prism' ByteString a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' a -> ByteString
rev (Result a -> Maybe a
forall r. Result r -> Maybe r
AL.maybeResult (Result a -> Maybe a)
-> (ByteString -> Result a) -> ByteString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
AL.parse Parser a
fwd (ByteString -> Result a)
-> (ByteString -> ByteString) -> ByteString -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ByteString ByteString ByteString
-> ByteString -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString ByteString ByteString
forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons)

-- | Parse an @a@.
--
-- The input is convered to a /lazy/ @ByteString@.
-- Build with rewrite rules enabled (@-O@, cabal's default)
-- to achieve the following conversion overheads:
--
-- * Lazy @ByteString@: no conversion
-- * Strict @ByteString@: /O(1)/ conversion
-- * @[Word8]@: /O(n)/ conversion
--
-- It is __recommended to use strict bytestring__ input.  Parsing a
-- lazy bytestring will cause numerous parser buffer resizes.  The
-- lazy chunks in the input can be GC'd but the buffer keeps growing
-- so you don't actually keep the memory usage low by using a lazy
-- bytestring.
--
parse :: (Cons s s Word8 Word8) => Parser a -> s -> Either String a
parse :: Parser a -> s -> Either String a
parse Parser a
p = Result a -> Either String a
forall r. Result r -> Either String r
AL.eitherResult (Result a -> Either String a)
-> (s -> Result a) -> s -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
AL.parse Parser a
p (ByteString -> Result a) -> (s -> ByteString) -> s -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ByteString s ByteString -> s -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString s ByteString
forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons
{-# INLINE parse #-}


-- | Email address with optional display name.
-- The @Eq@ instance compares the display name case
-- sensitively and the address as described at 'AddrSpec'.
--
data Mailbox =
    Mailbox (Maybe T.Text {- display name -})
             AddrSpec
    deriving (Int -> Mailbox -> ShowS
[Mailbox] -> ShowS
Mailbox -> String
(Int -> Mailbox -> ShowS)
-> (Mailbox -> String) -> ([Mailbox] -> ShowS) -> Show Mailbox
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mailbox] -> ShowS
$cshowList :: [Mailbox] -> ShowS
show :: Mailbox -> String
$cshow :: Mailbox -> String
showsPrec :: Int -> Mailbox -> ShowS
$cshowsPrec :: Int -> Mailbox -> ShowS
Show, Mailbox -> Mailbox -> Bool
(Mailbox -> Mailbox -> Bool)
-> (Mailbox -> Mailbox -> Bool) -> Eq Mailbox
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mailbox -> Mailbox -> Bool
$c/= :: Mailbox -> Mailbox -> Bool
== :: Mailbox -> Mailbox -> Bool
$c== :: Mailbox -> Mailbox -> Bool
Eq, (forall x. Mailbox -> Rep Mailbox x)
-> (forall x. Rep Mailbox x -> Mailbox) -> Generic Mailbox
forall x. Rep Mailbox x -> Mailbox
forall x. Mailbox -> Rep Mailbox x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Mailbox x -> Mailbox
$cfrom :: forall x. Mailbox -> Rep Mailbox x
Generic, Mailbox -> ()
(Mailbox -> ()) -> NFData Mailbox
forall a. (a -> ()) -> NFData a
rnf :: Mailbox -> ()
$crnf :: Mailbox -> ()
NFData)

instance IsString Mailbox where
  fromString :: String -> Mailbox
fromString =
    (String -> Mailbox)
-> (Mailbox -> Mailbox) -> Either String Mailbox -> Mailbox
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Mailbox
forall a. HasCallStack => String -> a
error (String -> Mailbox) -> ShowS -> String -> Mailbox
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
"Failed to parse Mailbox: ") Mailbox -> Mailbox
forall a. a -> a
id (Either String Mailbox -> Mailbox)
-> (String -> Either String Mailbox) -> String -> Mailbox
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Mailbox
readMailbox

-- | Email address.  The @Eq@ instances compares the local part
-- case sensitively, and the domain part as described at 'Domain'.
--
-- Address "detail" (section of local part after a @'+'@ character;
-- also called "extension" or "subaddress") is part of the local
-- part.  Therefore addresses that differ in this aspect, for
-- example @alice+bank\@example.com@ and @alice+spam\@example.com@,
-- are unequal.
--
data AddrSpec =
    AddrSpec B.ByteString {- local part -}
             Domain
    deriving (Int -> AddrSpec -> ShowS
[AddrSpec] -> ShowS
AddrSpec -> String
(Int -> AddrSpec -> ShowS)
-> (AddrSpec -> String) -> ([AddrSpec] -> ShowS) -> Show AddrSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddrSpec] -> ShowS
$cshowList :: [AddrSpec] -> ShowS
show :: AddrSpec -> String
$cshow :: AddrSpec -> String
showsPrec :: Int -> AddrSpec -> ShowS
$cshowsPrec :: Int -> AddrSpec -> ShowS
Show, AddrSpec -> AddrSpec -> Bool
(AddrSpec -> AddrSpec -> Bool)
-> (AddrSpec -> AddrSpec -> Bool) -> Eq AddrSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddrSpec -> AddrSpec -> Bool
$c/= :: AddrSpec -> AddrSpec -> Bool
== :: AddrSpec -> AddrSpec -> Bool
$c== :: AddrSpec -> AddrSpec -> Bool
Eq, (forall x. AddrSpec -> Rep AddrSpec x)
-> (forall x. Rep AddrSpec x -> AddrSpec) -> Generic AddrSpec
forall x. Rep AddrSpec x -> AddrSpec
forall x. AddrSpec -> Rep AddrSpec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AddrSpec x -> AddrSpec
$cfrom :: forall x. AddrSpec -> Rep AddrSpec x
Generic, AddrSpec -> ()
(AddrSpec -> ()) -> NFData AddrSpec
forall a. (a -> ()) -> NFData a
rnf :: AddrSpec -> ()
$crnf :: AddrSpec -> ()
NFData)

data Address
    = Single Mailbox
    | Group T.Text {- display name -}
            [Mailbox]
    deriving (Int -> Address -> ShowS
[Address] -> ShowS
Address -> String
(Int -> Address -> ShowS)
-> (Address -> String) -> ([Address] -> ShowS) -> Show Address
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Address] -> ShowS
$cshowList :: [Address] -> ShowS
show :: Address -> String
$cshow :: Address -> String
showsPrec :: Int -> Address -> ShowS
$cshowsPrec :: Int -> Address -> ShowS
Show, Address -> Address -> Bool
(Address -> Address -> Bool)
-> (Address -> Address -> Bool) -> Eq Address
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Address -> Address -> Bool
$c/= :: Address -> Address -> Bool
== :: Address -> Address -> Bool
$c== :: Address -> Address -> Bool
Eq, (forall x. Address -> Rep Address x)
-> (forall x. Rep Address x -> Address) -> Generic Address
forall x. Rep Address x -> Address
forall x. Address -> Rep Address x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Address x -> Address
$cfrom :: forall x. Address -> Rep Address x
Generic, Address -> ()
(Address -> ()) -> NFData Address
forall a. (a -> ()) -> NFData a
rnf :: Address -> ()
$crnf :: Address -> ()
NFData)

-- | A DNS name or "domain literal" (address literal).
-- DNS names are compared case-insensitively.
data Domain
    = DomainDotAtom (NonEmpty (CI B.ByteString) {- printable ascii -})
    | DomainLiteral B.ByteString
    deriving (Int -> Domain -> ShowS
[Domain] -> ShowS
Domain -> String
(Int -> Domain -> ShowS)
-> (Domain -> String) -> ([Domain] -> ShowS) -> Show Domain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Domain] -> ShowS
$cshowList :: [Domain] -> ShowS
show :: Domain -> String
$cshow :: Domain -> String
showsPrec :: Int -> Domain -> ShowS
$cshowsPrec :: Int -> Domain -> ShowS
Show, Domain -> Domain -> Bool
(Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool) -> Eq Domain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Domain -> Domain -> Bool
$c/= :: Domain -> Domain -> Bool
== :: Domain -> Domain -> Bool
$c== :: Domain -> Domain -> Bool
Eq, (forall x. Domain -> Rep Domain x)
-> (forall x. Rep Domain x -> Domain) -> Generic Domain
forall x. Rep Domain x -> Domain
forall x. Domain -> Rep Domain x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Domain x -> Domain
$cfrom :: forall x. Domain -> Rep Domain x
Generic, Domain -> ()
(Domain -> ()) -> NFData Domain
forall a. (a -> ()) -> NFData a
rnf :: Domain -> ()
$crnf :: Domain -> ()
NFData)