purebred-email 0.4.3 → 0.5

raw patch · 31 files changed

+2724/−1324 lines, 31 filesdep +randomdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependency ranges changed: time

API changes (from Hackage documentation)

Files

• README.rst +2/−1
• purebred-email.cabal +29/−18
• src/Data/IMF.hs +950/−0
• src/Data/IMF.hs-boot +19/−0
• src/Data/IMF/DateTime.hs +175/−0
• src/Data/IMF/Syntax.hs +407/−0
• src/Data/IMF/Text.hs +133/−0
• src/Data/IMF/Text.hs-boot +21/−0
• src/Data/MIME.hs +296/−204
• src/Data/MIME/Base64.hs +17/−1
• src/Data/MIME/Boundary.hs +79/−0
• src/Data/MIME/Charset.hs +74/−3
• src/Data/MIME/EncodedWord.hs +17/−1
• src/Data/MIME/Error.hs +16/−0
• src/Data/MIME/Internal.hs +16/−0
• src/Data/MIME/Parameter.hs +17/−1
• src/Data/MIME/QuotedPrintable.hs +16/−0
• src/Data/MIME/TransferEncoding.hs +16/−0
• src/Data/MIME/Types.hs +16/−0
• src/Data/RFC5322.hs +16/−518
• src/Data/RFC5322/Address/Text.hs +18/−107
• src/Data/RFC5322/Address/Types.hs +17/−28
• src/Data/RFC5322/Internal.hs +16/−373
• tests/ContentTransferEncodings.hs +16/−0
• tests/EncodedWord.hs +16/−3
• tests/Generator.hs +22/−6
• tests/Headers.hs +145/−44
• tests/MIME.hs +14/−7
• tests/Message.hs +7/−4
• tests/Parser.hs +105/−5
• tests/Test.hs +16/−0

@@ -1,1 +1,2 @@-Email handling library.  RFC 5322, MIME and more.+Email handling library.  RFC 5322, MIME and more.  See+`purebred-email.cabal` and the Haddock documentation for details.

@@ -1,29 +1,34 @@ cabal-version:       2.2 name:                purebred-email-version:             0.4.3+version:             0.5 synopsis:            types and parser for email messages (including MIME) description:   The purebred email library.  RFC 5322, MIME, etc.-  .-  Things that are currently implemented:+  See "Data.MIME" for usage, examples and API documentation.   .-  - RFC 5322 message parsing and serialisation-  - MIME multipart parsing (RFC 2046) and serialisation-  - MIME message header extensions for non-ASCII text (RFC 2047)-  - MIME parameter value and encoded word extensions (RFC 2231)-  - Content-Disposition header field (RFC 2183)-  - Message encapsulation (forward/bounce)+  This is a general-purpose library for processing and constructing+  email messages, originally written to meet the needs of+  <https://github.com/purebred-mua/purebred purebred MUA>.+  Transmission and delivery of mail are not part of this library,+  but /purebred-email/ could be a useful building block for such+  systems.   .-  Things that are not yet implemented / need improvement:+  Features and implemented specifications include:   .-  - Improve handling of dates-  - Probably lots of other things+  - <https://tools.ietf.org/html/rfc5322 RFC 5322> message parsing and serialisation+  - MIME multipart messages (<https://tools.ietf.org/html/rfc2046 RFC 2046>)+  - Convenient APIs for replying and forward/bounce+  - Content transfer and charset decoding/encoding+  - MIME message header extensions for non-ASCII text (<https://tools.ietf.org/html/rfc2047 RFC 2047>)+  - MIME parameter value and encoded word extensions (<https://tools.ietf.org/html/rfc2231 RFC 2231>)+  - @Content-Disposition@ header field (<https://tools.ietf.org/html/rfc2183 RFC 2183>)+  - Address syntax in @From@ and @Sender@ fields (<https://tools.ietf.org/html/rfc6854 RFC 6854>)  license:             AGPL-3.0-or-later license-file:        LICENSE author:              Fraser Tweedale maintainer:          frase@frase.id.au-copyright:           Copyright 2017-2019  Fraser Tweedale+copyright:           Copyright 2017-2021  Fraser Tweedale category:            Data, Email build-type:          Simple extra-source-files:@@ -31,7 +36,7 @@   test-vectors/*.eml   tests/golden/*.golden tested-with:-  GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1+  GHC ==8.8.4 || ==8.10.4 || ==9.0.1  homepage:            https://github.com/purebred-mua/purebred-email bug-reports:         https://github.com/purebred-mua/purebred-email/issues@@ -55,12 +60,15 @@     , lens >= 4 && < 6     , semigroups >= 0.16     , text >= 1.2-    , time >= 1.8+    , time >= 1.9  library   import: common   exposed-modules:-    Data.RFC5322+    Data.IMF+    , Data.IMF.Syntax+    , Data.IMF.Text+    , Data.RFC5322     , Data.RFC5322.Address.Text     , Data.RFC5322.Address.Types     , Data.RFC5322.Internal@@ -74,13 +82,15 @@     , Data.MIME.Base64     , Data.MIME.QuotedPrintable   other-modules:-    Data.MIME.Internal-  -- other-extensions:    +    Data.MIME.Boundary+    , Data.MIME.Internal+    , Data.IMF.DateTime   build-depends:     , base64-bytestring >= 1 && < 2     , case-insensitive >= 1.2 && < 1.3     , concise >= 0.1.0.1 && < 1     , deepseq >= 1.4.2+    , random >= 1.2.0     , semigroupoids >= 5 && < 6     , stringsearch >= 0.3   hs-source-dirs:      src@@ -101,6 +111,7 @@     , Message   build-depends:     , purebred-email+    , random     , tasty     , tasty-hedgehog     , tasty-quickcheck

@@ -0,0 +1,950 @@+-- 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 (Eq, Show, Generic, NFData)++class HasHeaders a where+  headers :: Lens' a Headers++instance HasHeaders Headers where+  headers = id++type instance Index Headers = CI B.ByteString+type instance IxValue Headers = B.ByteString++instance Ixed Headers where+  ix = header++hdriso :: Iso' Headers [(CI B.ByteString, B.ByteString)]+hdriso = iso (\(Headers xs) -> xs) Headers++-- | Acts upon the first occurrence of the header only.+--+instance At Headers where+  at k = hdriso . l+    where+    l :: Lens' [(CI B.ByteString, B.ByteString)] (Maybe B.ByteString)+    l f kv =+      let+        i = findIndex ((== k) . fst) kv+        g Nothing = maybe kv (\j -> take j kv <> drop (j + 1) kv) i+        g (Just v) = maybe ((k,v):kv) (\j -> set (ix j) (k,v) kv) i+      in+        g <$> f (lookup k kv)+++-- | Target all values of the given header+header :: HasHeaders a => CI B.ByteString -> Traversal' a B.ByteString+header k = headerList . traversed . filtered ((k ==) . fst) . _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 (Show, Generic, NFData)++instance HasHeaders (Message s a) where+  headers f (Message h b) = fmap (`Message` b) (f h)++instance Functor (Message s) where+  fmap f (Message h a) = Message h (f 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 h1 b1) (Message h2 b2) = h1 == h2 && b1 == b2+++instance EqMessage a => Eq (Message s a) where+  (==) = eqMessage++-- | Access headers as a list of key/value pairs.+headerList :: HasHeaders a => Lens' a [(CI B.ByteString, B.ByteString)]+headerList = headers . coerced++body :: Lens (Message ctx a) (Message ctx' b) a b+body f (Message h b) = fmap (\b' -> Message h b') (f 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 = "%a, %d %b %Y %T %z"++renderRFC5322Date :: ZonedTime -> B.ByteString+renderRFC5322Date = Char8.pack . formatTime defaultTimeLocale rfc5322DateTimeFormat++headerDate :: HasHeaders a => Lens' a (Maybe ZonedTime)+headerDate = headers . at "Date" . iso (>>= p) (fmap renderRFC5322Date)+  where+  p = either (const Nothing) Just . parseOnly (dateTime <* endOfInput)++-- §3.4 Address Specification+buildMailbox :: Mailbox -> Builder.Builder+buildMailbox (Mailbox n a) =+  maybe a' (\n' -> buildPhrase n' <> " <" <> a' <> ">") n+  where+    a' = buildAddressSpec 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 "" = "\"\""+buildPhrase s =+  case enc s of+    PhraseAtom -> T.encodeUtf8Builder s+    PhraseQuotedString -> qsBuilder False+    PhraseQuotedStringEscapeSpace -> qsBuilder True+    PhraseEncodedWord -> buildEncodedWord . transferEncode . charsetEncode $ s+  where+    enc = snd . T.foldr (\c (prev, req) -> (c, encChar prev c <> req)) ('\0', mempty)+    encChar prev c+      | isAtext c = PhraseAtom+      | isQtext c = PhraseQuotedString+      | isVchar c = PhraseQuotedString+      | c == ' ' =+          if prev == ' '  -- two spaces in a row; need to avoid FWS+          then PhraseQuotedStringEscapeSpace+          else PhraseQuotedString+      | otherwise = PhraseEncodedWord++    qsBuilder escSpace = "\"" <> T.encodeUtf8BuilderEscaped (escPrim escSpace) s <> "\""+    escPrim escSpace = Prim.condB (\c -> isQtext c || not escSpace && c == 32)+      (Prim.liftFixedToBounded Prim.word8)+      (Prim.liftFixedToBounded $ (fromChar '\\',) Prim.>$< Prim.word8 Prim.>*< Prim.word8)++-- | Data type used to compute escaping requirement of a Text 'phrase'+--+data PhraseEscapeRequirement+  = PhraseAtom+  | PhraseQuotedString+  | PhraseQuotedStringEscapeSpace+  | PhraseEncodedWord+  deriving (Eq, Ord)++instance Semigroup PhraseEscapeRequirement where+  PhraseEncodedWord <> _ =+    -- allows early termination of folds+    PhraseEncodedWord+  l <> r = max l r++instance Monoid PhraseEscapeRequirement where+  mempty = PhraseAtom++++renderMailboxes :: [Mailbox] -> B.ByteString+renderMailboxes = L.toStrict . Builder.toLazyByteString . buildMailboxes++buildMailboxes :: [Mailbox] -> Builder.Builder+buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox++renderMailbox :: Mailbox -> B.ByteString+renderMailbox = L.toStrict . Builder.toLazyByteString . buildMailbox++mailbox :: CharsetLookup -> Parser Mailbox+mailbox charsets =+  Mailbox <$> optional (displayName charsets) <*> angleAddr+  <|> Mailbox Nothing <$> addressSpec++phrase :: CharsetLookup -> Parser T.Text+phrase charsets = foldMany1Sep " " $+  fmap (decodeEncodedWord charsets) ("=?" *> encodedWord)+  <|> fmap decodeLenient word++displayName :: CharsetLookup -> Parser T.Text+displayName = phrase++angleAddr :: Parser AddrSpec+angleAddr = optionalCFWS *>+  char8 '<' *> addressSpec <* char8 '>'+  <* optionalCFWS++buildAddressSpec :: AddrSpec -> Builder.Builder+buildAddressSpec (AddrSpec lp (DomainDotAtom b))+  | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest+  | otherwise = buildLP <> rest+  where+    buildLP = Builder.byteString lp+    rest = "@" <> foldMap (Builder.byteString . original)+                          (Data.List.NonEmpty.intersperse "." b)+buildAddressSpec (AddrSpec lp (DomainLiteral b)) =+  foldMap Builder.byteString [lp, "@", b]++renderAddressSpec :: AddrSpec -> B.ByteString+renderAddressSpec = L.toStrict . Builder.toLazyByteString . buildAddressSpec++addressSpec :: Parser AddrSpec+addressSpec = AddrSpec <$> localPart <*> (char8 '@' *> domain)++-- | Printable US-ASCII excl "[", "]", or "\"+isDtext :: Word8 -> Bool+isDtext c = (c >= 33 && c <= 90) || (c >= 94 && c <= 126)++domain :: Parser Domain+domain = (DomainDotAtom . fmap mk <$> dotAtom)+         <|> (DomainLiteral <$> domainLiteral)++mailboxList :: CharsetLookup -> Parser [Mailbox]+mailboxList charsets = mailbox charsets `sepBy` char8 ','++renderAddresses :: [Address] -> B.ByteString+renderAddresses xs = B.intercalate ", " $ renderAddress <$> xs++renderAddress :: Address -> B.ByteString+renderAddress (Single m) = renderMailbox m+renderAddress (Group name xs) = T.encodeUtf8 name <> ":" <> renderMailboxes xs <> ";"++addressList :: CharsetLookup -> Parser [Address]+addressList charsets = address charsets `sepBy` char8 ','++group :: CharsetLookup -> Parser Address+group charsets =+  Group <$> displayName charsets <* char8 ':'+        <*> mailboxList charsets <* char8 ';' <* optionalCFWS++address :: CharsetLookup -> Parser Address+address charsets =+  group charsets <|> Single <$> mailbox 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 f g k =+  headers . at k . iso (maybe [] f) (\l -> if null l then Nothing else Just (g 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 f g k = headers . at k . iso (>>= f) (fmap g)++headerAddressList :: (HasHeaders a) => CI B.ByteString -> CharsetLookup -> Lens' a [Address]+headerAddressList k charsets = headerSingleToList+  (fromRight [] . parseOnly (addressList charsets))+  renderAddresses+  k++headerFrom, headerReplyTo, headerTo, headerCC, headerBCC+  :: (HasHeaders a)+  => CharsetLookup -> Lens' a [Address]+headerFrom = headerAddressList "From"+headerReplyTo = headerAddressList "Reply-To"+headerTo = headerAddressList "To"+headerCC = headerAddressList "Cc"+headerBCC = headerAddressList "Bcc"++data MessageID = MessageID+  (NonEmpty B.ByteString)+  (Either (NonEmpty B.ByteString) B.ByteString)+  deriving (Eq, Ord)++instance Show MessageID where+  show = Char8.unpack . renderMessageID++parseMessageID :: Parser MessageID+parseMessageID =+  MessageID+    <$> (optionalCFWS *> char '<'  *> idLeft) <* char '@'+    <*> idRight <* char '>' <* optionalCFWS+  where+  idLeft = dotAtomText+  idRight = Left <$> dotAtomText <|> Right <$> noFoldLiteral+  noFoldLiteral = char '[' *> A.takeWhile1 isDtext <* char ']'++buildMessageID :: MessageID -> Builder.Builder+buildMessageID (MessageID l r) =+  "<" <> buildDotAtom l <> "@" <> either buildDotAtom buildNoFoldLit r <> ">"+  where+  buildDotAtom =+    fold . Data.List.NonEmpty.intersperse "." . fmap Builder.byteString+  buildNoFoldLit s =+    "[" <> Builder.byteString s <> "]"++renderMessageID :: MessageID -> B.ByteString+renderMessageID = L.toStrict . Builder.toLazyByteString . buildMessageID++headerMessageID :: (HasHeaders a) => Lens' a (Maybe MessageID)+headerMessageID = headerSingleToMaybe+  (either (const Nothing) Just . parseOnly (parseMessageID <* endOfInput))+  renderMessageID+  "Message-ID"++headerMessageIDList :: (HasHeaders a) => CI B.ByteString -> Lens' a [MessageID]+headerMessageIDList = headerSingleToList+  (fromRight [] . parseOnly (many parseMessageID <* endOfInput))+  ( L.toStrict . Builder.toLazyByteString+    . fold . Data.List.intersperse " " . fmap buildMessageID )++headerInReplyTo, headerReferences :: (HasHeaders a) => Lens' a [MessageID]+headerInReplyTo = headerMessageIDList "In-Reply-To"+headerReferences = headerMessageIDList "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 charsets k =+  headers . at k . iso (fmap (decodeEncodedWords charsets)) (fmap encodeEncodedWords)++-- | Subject header.  See 'headerText' for details of conversion to @Text@.+headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)+headerSubject charsets = headerText charsets "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+  { _replyMode            :: ReplyMode+  , _replyFromMode        :: ReplyFromMode+  , _replyFromRewriteMode :: ReplyFromRewriteMode+  , _selfInRecipientsMode :: SelfInRecipientsMode+  , _authorMailboxes      :: AuthorMailboxes+  }++-- | Given author mailboxes, get a default 'ReplySettings'.  The default+-- settings are: 'ReplyToSender', 'ReplyFromMatchingMailbox',+-- 'ReplyFromRewriteOn', and 'SelfInRecipientsRemove'.+--+defaultReplySettings :: AuthorMailboxes -> ReplySettings+defaultReplySettings = ReplySettings+  ReplyToSender+  ReplyFromMatchingMailbox+  ReplyFromRewriteOn+  SelfInRecipientsRemove++replyMode :: Lens' ReplySettings ReplyMode+replyMode = lens _replyMode (\s a -> s { _replyMode = a })++replyFromMode :: Lens' ReplySettings ReplyFromMode+replyFromMode = lens _replyFromMode (\s a -> s { _replyFromMode = a })++replyFromRewriteMode :: Lens' ReplySettings ReplyFromRewriteMode+replyFromRewriteMode =+  lens _replyFromRewriteMode (\s a -> s { _replyFromRewriteMode = a })++selfInRecipientsMode :: Lens' ReplySettings SelfInRecipientsMode+selfInRecipientsMode =+  lens _selfInRecipientsMode (\s a -> s { _selfInRecipientsMode = a })++authorMailboxes :: Lens' ReplySettings AuthorMailboxes+authorMailboxes = lens _authorMailboxes (\s a -> s { _authorMailboxes = a })+++replyRecipients+  :: CharsetLookup -> ReplySettings -> Message ctx a -> ([Address], [Address])+replyRecipients charsets settings msg =+  let+    mode = view replyMode settings+    rt = view (headerReplyTo charsets) msg+    f = view (headerFrom charsets) msg+    t = view (headerTo charsets) msg+    c = view (headerCC charsets) msg+  in case mode of+    ReplyToSender+      | not (null rt) -> (rt, [])+      | otherwise     -> (f, [])+    ReplyToGroup+      | length (t <> c) <= 1+      -> replyRecipients charsets (set replyMode ReplyToSender settings) msg+      | otherwise+      -> (f, t <> c)++replyReferences :: Message ctx a -> [MessageID]+replyReferences msg+  | null refer, length inRep == 1 = inRep <> msgId+  | otherwise                     = refer <> msgId+  where+  msgId = toList $ view headerMessageID msg+  refer = view headerReferences msg+  inRep = view headerInReplyTo msg++replySubject :: CharsetLookup -> Message ctx a -> T.Text+replySubject charsets msg = if prefixed then orig else "Re: " <> orig+  where+  orig = fold $ view (headerSubject charsets) msg+  prefixed = mk (T.take 3 orig) == "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 charsets settings msg =+  let+    self = view authorMailboxes settings++    getAddrSpec :: Mailbox -> AddrSpec+    getAddrSpec (Mailbox _ addr) = 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 xs (Single addr) =+      f <$> find (on (==) getAddrSpec addr) xs+      where+        f = case view replyFromRewriteMode settings of+          ReplyFromRewriteOn  -> id+          ReplyFromRewriteOff -> const addr+    findMatchingMailbox _ _ = Nothing++    getSelf :: Address -> Maybe Mailbox+    getSelf = findMatchingMailbox self++    isSelf :: Address -> Bool+    isSelf = isJust . getSelf++    findSelf =+      let+        parentTo = view (headerTo charsets) msg+        parentCc = view (headerCC charsets) msg+      in+        getFirst $ foldMap (First . getSelf) (parentTo <> parentCc)++    filterSelf = case view selfInRecipientsMode settings of+      SelfInRecipientsRemove -> filter (not . isSelf)+      SelfInRecipientsIgnore -> id++    (t, c) = replyRecipients charsets settings msg+    _To = filterSelf t+    _To_mailboxes = mapMaybe (\case Single a -> Just a ; _ -> Nothing) _To+    _Cc = c+          & filterSelf+          & filter (isNothing . findMatchingMailbox _To_mailboxes)+    _From =+      let preferred = Data.List.NonEmpty.head self+      in+        case view replyFromMode settings of+          ReplyFromPreferredMailbox -> preferred+          ReplyFromMatchingMailbox  -> fromMaybe preferred findSelf++    hdrs = Headers []+      & set (headerFrom charsets) [Single _From]+      & set (headerTo charsets) (filterSelf _To)+      & set (headerCC charsets) (filterSelf _Cc)+      & set headerInReplyTo (toList $ view headerMessageID msg)+      & set headerReferences (replyReferences msg)+      & set (headerSubject charsets) (Just $ replySubject charsets msg)+  in+    Message 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 f = fields >>= \hdrs -> Message hdrs <$> case f hdrs of+  RequiredBody b -> crlf *> b+  OptionalBody (b, a) -> optional crlf >>= maybe (pure a) (const b)+  NoBody b -> pure b++type family MessageContext a+++fields :: Parser Headers+fields = Headers <$> many 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 _ = 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 h b) =+  buildFields (tweakHeaders b h)+  <> maybe mempty ("\r\n" <>) (buildBody h 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 = Builder.toLazyByteString . buildMessage++-- Header serialisation+buildFields :: Headers -> Builder.Builder+buildFields = foldMapOf (hdriso . traversed) buildField++buildField :: (CI B.ByteString, B.ByteString) -> Builder.Builder+buildField (k,v) =+  let key = original k+  in+    Builder.byteString key+    <> ":"+    <> foldUnstructured v (B.length key + 1)+    <> "\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 s i = case Char8.words s of+  [] -> mempty+  (h:t) ->+    -- Special case to prevent wrapping of first word;+    -- see 6dbc04fb1863e845699b1cef50f4edaf1326bdae for info.+    " " <> Builder.byteString h <> go t (i + 1 + B.length h)+  where+  limit = 76  -- could be 78, but this preserves old behaviour+  go [] _ = mempty+  go (chunk:chunks) col+    | col <= 1 || col + 1 + B.length chunk < 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.byteString chunk <> go chunks (col + 1 + B.length chunk)+    | otherwise = "\r\n" <> go (chunk:chunks) 0  -- fold++-- | Printable ASCII excl. ':'+isFtext :: Word8 -> Bool+isFtext c = (c >= 33 && c <= 57) || (c >= 59 && c <= 126)++field :: Parser (CI B.ByteString, B.ByteString)+field = (,)+  <$> ci (takeWhile1 isFtext)+  <*  char8 ':' <* many wsp+  <*> unstructured <* crlf++unstructured :: Parser B.ByteString+unstructured =+  foldMany (optionalFWS <<>> (B.singleton <$> vchar))+  <<>> A.takeWhile 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 p = to (parse p) . folded+{-# INLINE parsed #-}++-- | Construct a prism from a parser and a printer+parsePrint :: Parser a -> (a -> B.ByteString) -> Prism' B.ByteString a+parsePrint fwd rev = prism' rev (AL.maybeResult . AL.parse fwd . view 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 p = AL.eitherResult . AL.parse p . view 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 (Show, Eq, Generic, NFData)++instance IsString Mailbox where+  fromString =+    either (error . mappend "Failed to parse Mailbox: ") id . 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 (Show, Eq, Generic, NFData)++data Address+    = Single Mailbox+    | Group T.Text {- display name -}+            [Mailbox]+    deriving (Show, Eq, Generic, 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 (Show, Eq, Generic, NFData)

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

@@ -0,0 +1,175 @@+-- This file is part of purebred-email+-- Copyright (C) 2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}++module Data.IMF.DateTime+  ( dateTime+  ) where++import Control.Applicative ((<|>), optional)+import Control.Monad (guard)+import Data.Functor (($>))++import Data.Attoparsec.ByteString as A+import Data.Attoparsec.ByteString.Char8 (char8, isDigit_w8)+import qualified Data.ByteString as B+import qualified Data.Time+import Data.Time+  ( Day, DayOfWeek(..), LocalTime(LocalTime), TimeOfDay, TimeZone(TimeZone)+  , ZonedTime(ZonedTime), fromGregorianValid, makeTimeOfDayValid+  , minutesToTimeZone, hoursToTimeZone, utc+  )+import Data.IMF.Syntax (fws, optionalCFWS, optionalFWS)++dateTime :: Parser ZonedTime+dateTime = do+  dow <- optional (dayOfWeek <* char8 ',')+  theDate <- date++  -- ensure day of week matches date+  case dow of+    Just dow' | Data.Time.dayOfWeek theDate /= dow'+      -> fail "day of week inconsistent with date"+    _ -> pure ()++  tod <- timeOfDay+  z <- zone+  _ <- optionalCFWS++  pure $ ZonedTime (LocalTime theDate tod) z+++dayOfWeek :: Parser DayOfWeek+dayOfWeek = optionalFWS *> dayName++dayName :: Parser DayOfWeek+dayName =+  string "Mon" $> Monday+  <|> string "Tue" $> Tuesday+  <|> string "Wed" $> Wednesday+  <|> string "Thu" $> Thursday+  <|> string "Fri" $> Friday+  <|> string "Sat" $> Saturday+  <|> string "Sun" $> Sunday+  <|> fail "invalid day-of-week"++date :: Parser Day+date = do+  d <- day+  m <- month+  y <- year+  case fromGregorianValid y m d of+    Just r -> pure r+    Nothing -> fail "invalid date"++day :: Parser Int+day = optionalFWS *> go <* fws+  where+  go = (twoDigit <|> digit) >>= check (\n -> n > 0 && n <= 31) "day out of range"++month :: Parser Int+month =+  string "Jan" $> 1+  <|> string "Feb" $> 2+  <|> string "Mar" $> 3+  <|> string "Apr" $> 4+  <|> string "May" $> 5+  <|> string "Jun" $> 6+  <|> string "Jul" $> 7+  <|> string "Aug" $> 8+  <|> string "Sep" $> 9+  <|> string "Oct" $> 10+  <|> string "Nov" $> 11+  <|> string "Dec" $> 12+  <|> fail "invalid month"++year :: Parser Integer+year = fws *> (go >>= check (>= 1900) "year cannot be < 1900") <* fws+  where+  go = fourOrMoreDigit <|> obsYear <|> fail "too few digits in year"+  fourOrMoreDigit = do+    digits <- A.takeWhile isDigit_w8+    guard (B.length digits >= 4)+    pure (B.foldl' step 0 digits)+  step r a = r * 10 + fromIntegral (a - 48)+  obsYear = do+    yy <- twoDigit+    fromIntegral+      . maybe (yy + if yy <= 49 then 2000 else 1900) (1900 + yy * 10 +)+      <$> optional digit++timeOfDay :: Parser TimeOfDay+timeOfDay = do+  hour <- twoDigit+  _ <- char8 ':'+  minute <- twoDigit+  second <- char8 ':' *> twoDigit <|> pure 0+  case makeTimeOfDayValid hour minute (fromIntegral second) of+    Nothing -> fail "invalid time-of-day"+    Just tod -> pure tod++zone :: Parser TimeZone+zone = fws *> (go <|> obsZone)+  where+  go = do+    posNeg <- char8 '+' $> id <|> char8 '-' $> negate+    h <- twoDigit+    m <- twoDigit+    guardFail (m <= 59) "zone minutes must be in range 0..59"+    pure $ minutesToTimeZone (posNeg (h * 60 + m))++obsZone :: Parser TimeZone+obsZone =+  utc <$ (string "GMT" <|> string "UT")+  <|> usZone+  <|> milZone+  where+  usZone = do+    (off, c1) <-+      charVal (-5) 'E'      -- eastern+      <|> charVal (-6) 'C'  -- central+      <|> charVal (-7) 'M'  -- mountain+      <|> charVal (-8) 'P'  -- pacific+    (dst, c2) <- charVal 0 'S' <|> charVal 1 'D'  -- standard / dst+    _ <- char8 'T'+    pure $ TimeZone ((off + dst) * 60) (dst == 1) (c1:c2:"T")+  charVal a c = (a, c) <$ char8 c+  milZone =+    utc <$ (char8 'Z' <|> char8 'z')+    <|> go     id 0x40 0x41 0x49  -- A..I+    <|> go     id 0x41 0x4b 0x4d  -- K..M+    <|> go negate 0x4d 0x4c 0x59  -- N..Y+    <|> go     id 0x60 0x61 0x69  -- a..i+    <|> go     id 0x61 0x6b 0x6d  -- k..m+    <|> go negate 0x6d 0x6e 0x79  -- n..y+  go f off lo hi =+    hoursToTimeZone . f . subtract off . fromIntegral+    <$> satisfy (\c -> c >= lo && c <= hi)+++guardFail :: Bool -> String -> Parser ()+guardFail True _ = pure ()+guardFail False s = fail s++check :: (a -> Bool) -> String -> a -> Parser a+check f s a = guardFail (f a) s $> a++digit :: Parser Int+digit = (\c -> fromIntegral (c - 48)) <$> satisfy isDigit_w8++twoDigit :: Parser Int+twoDigit = (\hi lo -> hi * 10 + lo) <$> digit <*> digit

@@ -0,0 +1,407 @@+-- 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 CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |++Parsers for low-level productions in the Internet Message Format.+These parsers are used throughout this library and may be useful+to other programs.++-}+module Data.IMF.Syntax+  (+  -- * Case-insensitive value parsers+    ci+  , CI+  , mk+  , original++  -- * Abstract character parsers+  , wsp+  , fws+  , optionalFWS+  , optionalCFWS+  , crlf+  , vchar+  , word+  , quotedString+  , dotAtomText+  , dotAtom+  , localPart+  , domainLiteral+  , IsChar(..)+  , char+  , CharParsing(..)+  , SM++  -- ** Helpers for building parsers+  , isAtext+  , isQtext+  , isVchar+  , isWsp++  -- * Semigroup and monoid folding combinators+  , (<<>>)+  , foldMany+  , foldMany1+  , foldMany1Sep++  -- * General parsers and combinators+  , skipTill+  , takeTill'++  -- * Efficient string search+  , skipTillString+  , takeTillString++  ) where++import Prelude hiding (takeWhile)+import Control.Applicative ((<|>), Alternative, liftA2, many, optional)+import Control.Monad (void)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Internal as A+import qualified Data.Attoparsec.Internal.Types as AT+import qualified Data.Attoparsec.Text as AText+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w, w2c)+import Data.ByteString.Search (indices)+import Data.CaseInsensitive (CI, FoldCase, mk, original)+import Data.Char (chr)+import Data.Foldable (fold)+import Data.Functor (($>))+import Data.List.NonEmpty (NonEmpty, fromList, intersperse)+import Data.Semigroup.Foldable (fold1)+import qualified Data.Text as T+import Data.Word (Word8)+++-- | Constraint synonym to handle the Semigroup Monoid Proposal+-- transition gracefully.+#if MIN_VERSION_base(4,11,0)+type SM a = Monoid a+#else+type SM a = (Semigroup a, Monoid a)+#endif++class IsChar a where+  toChar :: a -> Char+  fromChar :: Char -> a++instance IsChar Char where+  toChar = id+  fromChar = id++instance IsChar Word8 where+  toChar = w2c+  fromChar = c2w++class IsChar a => CharParsing f s a | s -> a, a -> f s where+  singleton :: Char -> s+  satisfy :: (Char -> Bool) -> (f s) a+  takeWhile :: (Char -> Bool) -> (f s) s+  takeWhile1 :: (Char -> Bool) -> (f s) s++instance CharParsing AT.Parser B.ByteString Word8 where+  singleton = B.singleton . c2w+  satisfy f = A.satisfy (f . w2c)+  takeWhile f = A.takeWhile (f . w2c)+  takeWhile1 f = A.takeWhile1 (f . w2c)++instance CharParsing AT.Parser T.Text Char where+  singleton = T.singleton+  satisfy = AText.satisfy+  takeWhile = AText.takeWhile+  takeWhile1 = AText.takeWhile1++char :: CharParsing f s a => Char -> (f s) a+char c = satisfy (== c)++isWsp :: IsChar c => c -> Bool+isWsp = AText.inClass "\t " . toChar++wsp :: CharParsing f s a => (f s) a+wsp = satisfy isWsp++isVchar :: IsChar c => c -> Bool+isVchar c =+  let c' = toChar c+  in c' >= chr 0x21 && c' <= chr 0x7e++vchar :: CharParsing f s a => (f s) a+vchar = satisfy isVchar++dquote :: CharParsing f s a => (f s) a+dquote = char '"'++quotedPair :: (Alternative (f s)) => CharParsing f s a => (f s) a+quotedPair = char '\\' *> (vchar <|> wsp)++-- §3.2.4.  Quoted Strings++isQtext :: IsChar c => c -> Bool+isQtext c' =+  let c = toChar c'+  in+    c == chr 33+    || (c >= chr 35 && c <= chr 91)+    || (c >= chr 93 && c <= chr 126)++quotedString :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+quotedString =+  optionalCFWS *> dquote+  *> foldMany (optionalFWS <<>> qcontent) <<>> optionalFWS+  <* dquote <* optionalCFWS+  where+    qcontent =+      (singleton . toChar <$> satisfy isQtext)+      <|> (singleton . toChar <$> quotedPair)++isAtext :: IsChar c => c -> Bool+isAtext = AText.inClass "-A-Za-z0-9!#$%&'*+/=?^_`{|}~" . toChar++atext :: CharParsing f s a => (f s) a+atext = satisfy isAtext++-- | Either CRLF or LF (lots of mail programs transform CRLF to LF)+crlf :: (Alternative (f s)) => CharParsing f s a => (f s) ()+crlf = void ((char '\r' *> char '\n') <|> char '\n')++-- §3.2.2.  Folding White Space and Comments+--+-- "The general rule is that wherever this specification allows for folding+-- white space (not simply WSP characters), a CRLF may be inserted before any+-- WSP."++-- | Folding white space (FWS).  A run of one or more whitespace+-- characters.  Returns a single SPACE character.+fws :: (Alternative (f s), CharParsing f s a) => (f s) s+fws = ( optional (takeWhile isWsp *> crlf) *> takeWhile1 isWsp )+      $> singleton ' '++-- | FWS collapsed to a single SPACE character, or empty string+--+optionalFWS :: (Alternative (f s), CharParsing f s a, Monoid s) => (f s) s+optionalFWS = fws <|> pure mempty++-- | Printable ASCII excl. '(', ')', '\'+isCtext :: Char -> Bool+isCtext c =+  c >= chr 33 && c <= chr 39+  || c >= chr 42 && c <= chr 91+  || c >= chr 93 && c <= chr 126++ccontent :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+ccontent = (singleton . toChar <$> satisfy isCtext) <|> comment++comment :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+comment =+  char '(' *> foldMany (optionalFWS <<>> ccontent) <* optionalFWS <* char ')'++cfws :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+cfws =+  ((foldMany1 (optionalFWS <<>> comment) *> optionalFWS) $> singleton ' ')+  <|> fws++-- | CFWS collapsed to a single SPACE character, or empty string+--+optionalCFWS :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+optionalCFWS = cfws <|> pure mempty++atom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+atom = optionalCFWS *> foldMany1 (singleton . toChar <$> atext) <* optionalCFWS++word :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+word = atom <|> quotedString++dotAtomText :: (Alternative (f s), CharParsing f s a) => (f s) (NonEmpty s)+dotAtomText = fromList <$> (takeWhile1 isAtext `A.sepBy1` char '.')++dotAtom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) (NonEmpty s)+dotAtom = optionalCFWS *> dotAtomText <* optionalCFWS++localPart :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+localPart = (fold . intersperse (singleton '.') <$> dotAtom) <|> quotedString++-- | Printable US-ASCII excl "[", "]", or "\"+isDtext :: Char -> Bool+isDtext c = (c >= chr 33 && c <= chr 90) || (c >= chr 94 && c <= chr 126)++dText :: CharParsing f s a => (f s) a+dText = satisfy isDtext++domainLiteral :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s+domainLiteral =+  optionalCFWS *> char '['+  *> foldMany (optionalFWS <<>> (singleton . toChar <$> dText) <<>> optionalFWS)+  <* char ']' <* optionalFWS+++-- | Modify a parser to produce a case-insensitive value+--+ci :: FoldCase s => A.Parser s -> A.Parser (CI s)+ci = fmap mk+++-- | Combine two semigroup parsers into one+(<<>>) :: (Semigroup m, Applicative f) => f m -> f m -> f m+(<<>>) = liftA2 (<>)++-- | Parse zero or more values and fold them+foldMany :: (Monoid m, Alternative f) => f m -> f m+foldMany = fmap fold . many++-- | Parse one or more values and fold them+foldMany1 :: (Semigroup m, Alternative f) => f m -> f m+foldMany1 = fmap (fold1 . fromList) . A.many1++-- | Parse one or more values and fold them with a separating element+foldMany1Sep :: (Semigroup m, Alternative f) => m -> f m -> f m+foldMany1Sep sep = fmap (fold1 . intersperse sep . fromList) . A.many1++-- | Skip until the given parser succeeds+--+-- @@+-- λ> parseOnly (string "foo" *> skipTill (string ".") *> endOfInput) "foobar."+-- Right ()+-- @@+--+skipTill :: A.Parser a -> A.Parser ()+skipTill = void . spanTill++-- | Current offset in the input+position :: AT.Parser i Int+position = AT.Parser $ \t pos more _lose suc -> suc t pos more (AT.fromPos pos)++-- | Number of elements between current position and first position+-- at which parser matches (fails if it never matches).  Also+-- consumes the input on which the parser succeeds.+--+-- @@+-- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar."+-- Right 3+-- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar"+-- Left "not enough input"+-- @@+--+spanTill :: A.Parser a -> A.Parser Int+spanTill p = liftA2 (flip (-)) position q+  where+  q = position <* p <|> A.anyWord8 *> q++-- | Run the parser from the specified offset.+--+-- Should only be used to seek backwards, otherwise+-- you could seek beyond the buffer.  User beware.+--+-- @@+-- λ> parseOnly (seek 3 *> takeByteString) "foobar"+-- Right "bar"+-- @@+--+seek :: Int -> A.Parser ()+seek pos = AT.Parser $ \t _pos more _lose win -> win t (AT.Pos pos) more ()++-- | Take until the parser matches (fails if it never matches).+--+-- @@+-- λ> parseOnly (takeTill' (string "bar") <* endOfInput) "foobar"+-- Right "foo"+-- @@+--+takeTill' :: A.Parser a -> A.Parser B.ByteString+takeTill' p = do+  pos <- position+  off <- spanTill p+  newPos <- position+  seek pos *> A.take off <* seek newPos++-- | Number of elements between current position and first position+-- at which the pattern matches (fails if it never matches).  Also+-- consumes the pattern.+--+-- Uses Boyer-Moore algorithm to efficiently search the input.+--+-- @@+-- λ> parseOnly (string "foo" *> spanTillString ".") "foobar."+-- Right 3+-- λ> parseOnly (string "foo" *> spanTillString ".") "foobar"+-- Left "not enough input"+-- @@+--+spanTillString :: B.ByteString -> A.Parser Int+spanTillString pat+  | B.null pat = position+  | otherwise = position >>= go+  where+  search = indices pat+  go start = do+    pos <- position+    buf <- takeBuffer+    case search buf of+      (offset:_) ->+        -- Pattern was found.  Seek to end of pattern and return the span+        seek (pos + offset + B.length pat) $> pos + offset - start+      _ ->+        -- We hit the end of the buffer without a match.  Seek to+        -- (length buf - length pat), demand more input and go again.+        seek (max start (B.length buf - B.length pat)) *> A.demandInput *> go start++-- | Efficient skip, using Boyer-Moore to locate the pattern.+--+-- @@+-- λ> parseOnly (string "foo" *> skipTillString "." *> endOfInput) "foobar."+-- Right ()+-- @@+--+skipTillString :: B.ByteString -> A.Parser ()+skipTillString = void . spanTillString++-- | Efficient take, using Boyer-Moore to locate the pattern.+--+-- @@+-- λ> parseOnly (takeTillString "bar" <* endOfInput) "foobar"+-- Right "foo"+-- @@+--+takeTillString :: B.ByteString -> A.Parser B.ByteString+takeTillString pat = do+  pos <- position+  off <- spanTillString pat+  newPos <- position+  seek pos *> A.take off <* seek newPos++-- | /O(1)/ Take the rest of the buffer, but do not demand+-- any more input.+--+takeBuffer :: A.Parser B.ByteString+takeBuffer = do+  start <- position+  end <- bufSize+  A.take (end - start)++bufSize :: forall t. AT.Chunk t => AT.Parser t Int+bufSize = AT.Parser $+  \t pos more _lose win ->+    win t pos more+      (AT.fromPos $ AT.atBufferEnd (undefined :: t) t)

@@ -0,0 +1,133 @@+-- This file is part of purebred-email+-- Copyright (C) 2018-2021  Róman Joost and Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}+{- |++@Text@ parsers and printers for mailbox and address types.++-}+module Data.IMF.Text+  (+    mailbox+  , mailboxList+  , readMailbox+  , address+  , addressList+  -- * Pretty printing+  , renderMailbox+  , renderMailboxes+  , renderAddress+  , renderAddresses+  , renderAddressSpec+  ) where++import Control.Applicative ((<|>), optional)+import Data.CaseInsensitive+import Data.Foldable (fold)+import Data.List (intersperse)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Internal.Builder as Builder+import qualified Data.ByteString as B+import Data.Attoparsec.Text as A hiding (char, parse, take)+import Data.List.NonEmpty (intersperse)++import Data.MIME.Charset (decodeLenient)+import Data.IMF (Mailbox(..), Address(..), AddrSpec(..), Domain(..))+import Data.IMF.Syntax+++renderMailboxes :: [Mailbox] -> T.Text+renderMailboxes = LT.toStrict . Builder.toLazyText . buildMailboxes++buildMailboxes :: [Mailbox] -> Builder.Builder+buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox++renderMailbox :: Mailbox -> T.Text+renderMailbox = LT.toStrict . Builder.toLazyText . buildMailbox++-- | Printing function to "pretty print" the mailbox for display purposes+buildMailbox :: Mailbox -> Builder.Builder+buildMailbox (Mailbox n a) =+  maybe a' (\n' -> "\"" <> Builder.fromText n' <> "\" " <> "<" <> a' <> ">") n+  where+    a' = buildAddressSpec a++renderAddresses :: [Address] -> T.Text+renderAddresses xs = T.intercalate ", " $ renderAddress <$> xs++renderAddress :: Address -> T.Text+renderAddress (Single m) = renderMailbox m+renderAddress (Group name xs) = name <> ":" <> renderMailboxes xs <> ";"++buildAddressSpec :: AddrSpec -> Builder.Builder+buildAddressSpec (AddrSpec lp (DomainDotAtom b))+  | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest+  | otherwise = buildLP <> rest+  where+    buildLP = Builder.fromText $ decodeLenient lp+    rest = "@" <> foldMap (Builder.fromText . decodeLenient . original)+                          (Data.List.NonEmpty.intersperse "." b)+buildAddressSpec (AddrSpec lp (DomainLiteral b)) =+  foldMap Builder.fromText [decodeLenient lp, "@", decodeLenient b]++renderAddressSpec :: AddrSpec -> T.Text+renderAddressSpec = LT.toStrict . Builder.toLazyText . buildAddressSpec+++-- §3.4 Address Specification+mailbox :: Parser Mailbox+mailbox = Mailbox <$> optional displayName <*> angleAddr+          <|> Mailbox Nothing <$> addressSpec++-- | Parse a (whole) string, returning an error @String@ or a 'Mailbox'.+readMailbox :: String -> Either String Mailbox+readMailbox = parseOnly (mailbox <* endOfInput) . T.pack++-- | Version of 'phrase' that does not process encoded-word+-- (we are parsing Text so will assume that the input does not+-- contain encoded words.  TODO this is probably wrong :)+phrase :: Parser T.Text+phrase = foldMany1Sep (singleton ' ') word++displayName :: Parser T.Text+displayName = phrase++mailboxList :: Parser [Mailbox]+mailboxList = mailbox `sepBy` char ','++addressList :: Parser [Address]+addressList = address `sepBy` char ','++group :: Parser Address+group = Group <$> displayName <* char ':' <*> mailboxList <* char ';' <* optionalCFWS++address :: Parser Address+address = group <|> Single <$> mailbox++angleAddr :: Parser AddrSpec+angleAddr = optionalCFWS *>+  char '<' *> addressSpec <* char '>'+  <* optionalCFWS++addressSpec :: Parser AddrSpec+addressSpec = AddrSpec <$> (T.encodeUtf8 <$> localPart) <*> (char '@' *> domain)++domain :: Parser Domain+domain = (DomainDotAtom . fmap (mk . T.encodeUtf8) <$> dotAtom)+         <|> (DomainLiteral . T.encodeUtf8 <$> domainLiteral)

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

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2017-2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}@@ -8,11 +24,8 @@  {- | -MIME messages (RFC 2045, RFC 2046, RFC 2183 and friends).--This module extends "Data.RFC5322" with types for handling MIME-messages.  It provides the 'mime' parsing helper function for-use with 'message'.+This module extends "Data.IMF" with types for handling MIME messages+(RFC 2045, 2046, 2183 and others).  -} module Data.MIME@@ -61,10 +74,17 @@   , ctType   , ctSubtype   , matchContentType-  , ctEq   , parseContentType   , renderContentType   , showContentType++  -- *** @multipart@ media type+  , MultipartSubtype(..)++  -- **** @boundary@ parameter+  , Boundary+  , makeBoundary+  , unBoundary   , mimeBoundary    -- *** Content-Type values@@ -88,30 +108,23 @@   , createAttachment   , createAttachmentFromFile   , createMultipartMixedMessage+  , setTextPlainBody++  -- *** Forward   , encapsulate-  -- *** Setting headers-  , headerFrom-  , headerTo-  , headerCC-  , headerBCC-  , headerDate-  , headerSubject-  , headerText-  , replyHeaderReferences    -- * Re-exports   , CharsetLookup   , defaultCharsets-  , module Data.RFC5322+  , module Data.IMF   , module Data.MIME.Parameter   , module Data.MIME.Error   ) where  import Control.Applicative-import Data.Either (fromRight) import Data.Foldable (fold) import Data.List.NonEmpty (NonEmpty, fromList, intersperse)-import Data.Maybe (fromMaybe, catMaybes)+import Data.Maybe (fromMaybe) import Data.String (IsString(fromString)) import GHC.Generics (Generic) @@ -125,11 +138,10 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Time.Clock (UTCTime)-import Data.Time.Format (defaultTimeLocale, parseTimeM) -import Data.RFC5322-import Data.RFC5322.Internal hiding (takeWhile1)+import Data.IMF+import Data.IMF.Syntax hiding (takeWhile1)+import Data.MIME.Boundary import Data.MIME.Error import Data.MIME.Charset import Data.MIME.EncodedWord@@ -141,10 +153,11 @@ Create an __inline, plain text message__ and __render__ it:  @+λ> :set -XOverloadedStrings λ> import Data.MIME λ> msg = 'createTextPlainMessage' "Hello, world!" λ> s = 'renderMessage' msg-λ> L.putStrLn s+λ> Data.ByteString.Lazy.Char8.putStrLn s MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline@@ -153,16 +166,27 @@ Hello, world! @ -Set the __@From@__ and __@To@__ headers:+Optics are provided for getting and setting the __sender and recipient__+fields:  @-λ> alice = Mailbox Nothing (AddrSpec "alice" (DomainDotAtom ("example" :| ["com"])))-λ> bob = Mailbox Nothing (AddrSpec "bob" (DomainDotAtom ("example" :| ["net"])))-λ> msgFromAliceToBob = set ('headerFrom' 'defaultCharsets' [alice] . set ('headerTo' defaultCharsets) [Single bob] $ msg-λ> L.putStrLn (renderMessage msgFromAliceToBob)+'headerFrom', 'headerReplyTo', 'headerTo', 'headerCC', 'headerBCC'+  :: ('HasHeaders' a)+  => 'CharsetLookup' -> Lens' a ['Address']+@++Example:++@+λ> alice = 'Single' "alice\@example.com"+λ> :t alice+alice :: 'Address'+λ> bob = 'Single' "bob\@example.net"+λ> msgFromAliceToBob = set ('headerFrom' 'defaultCharsets') [alice] . set ('headerTo' defaultCharsets) [bob] $ msg+λ> Data.ByteString.Lazy.Char8.putStrLn ('renderMessage' msgFromAliceToBob) MIME-Version: 1.0-From: alice@example.com-To: bob@example.net+From: alice\@example.com+To: bob\@example.net Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-Type: text/plain; charset=us-ascii@@ -170,19 +194,23 @@ Hello, world! @ -The 'headerFrom', 'headerTo', 'headerCC' and 'headerBCC' lenses are the most-convenient interface for reading and setting the __sender and recipient addresses__.-Note that you would usually not manually construct email addresses-manually as was done above.  Instead you would usually read it from another-email or configuration, or parse addresses from user input.+__NOTE__: the values @alice@ and @bob@ in the above example make use+of the __non-total__ @instance 'IsString' 'Mailbox'@.  This instance+is provided as convenience for static values.  For parsing mailboxes,+use one of: +@+Data.IMF.'Data.IMF.mailbox'      :: 'CharsetLookup' -> Parser ByteString Mailbox+Data.IMF.Text.'Data.IMF.Text.mailbox' ::                  Parser       Text Mailbox+@+ The __@Subject@__ header is set via 'headerSubject'.  __Other single-valued headers__ can be set via 'headerText'.  @ λ> :{-| L.putStrLn . renderMessage $-|   set ('headerText' defaultCharsets "Comments") (Just "와")+| Data.ByteString.Lazy.Char8.putStrLn . 'renderMessage' $+|   set ('headerText' defaultCharsets \"Comments\") (Just "와") |   . set ('headerSubject' defaultCharsets) (Just "Hi from Alice") |   $ msgFromAliceToBob | :}@@ -190,8 +218,8 @@ MIME-Version: 1.0 Comments: =?utf-8?B?7JmA?= Subject: Hi from Alice-From: alice@example.com-To: bob@example.net+From: alice\@example.com+To: bob\@example.net Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-Type: text/plain; charset=us-ascii@@ -199,33 +227,49 @@ Hello, world! @ +To create __multipart messages__ you need to construct a 'Boundary' value.+Boundary values should be unique (not appearing elsewhere in a message).+High-entropy random values are good.  You can use 'mkBoundary' to construct a+value (checking that the input is a legal value).  Or you can ask+/purebred-email/ to generate a conformant value, as below.++@+λ> import System.Random+λ> boundary <- getStdRandom uniform :: IO Boundary+λ> boundary+Boundary "MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w"+@+ Create a __multipart message with attachment__:  @-λ> attachment = 'createAttachment' "application/json" (Just "data.json") "{\"foo\":42}"-λ> msg2 = 'createMultipartMixedMessage' "boundary" [msg, attachment]+λ> attachment = 'createAttachment' "application/json" (Just "data.json") "{\\"foo\\":42}"+λ> msg2 = 'createMultipartMixedMessage' boundary (msg :| [attachment]) λ> s2 = 'renderMessage' msg2-λ> L.putStrLn s2+λ> Data.ByteString.Lazy.Char8.putStrLn s2 MIME-Version: 1.0-Content-Type: multipart/mixed; boundary=boundary+Content-Type: multipart/mixed;+ boundary="MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w" ---boundary+--MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w+MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-Type: text/plain; charset=us-ascii  Hello, world!---boundary+--MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w+MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=data.json Content-Type: application/json  {"foo":42}---boundary--+--MEgno8wUdTT\/g8vB,vj.3K8sjU6i_r=CFf1jqrAmnxrv0a\/9PA'G4hQ8oE,u016w--  @ -__NOTE:__ if you only need to write a serialised 'Message' to an +__NOTE:__ for writing a 'Message' to an  IO handle, 'buildMessage' is more efficient than 'renderMessage'.  -}@@ -253,11 +297,12 @@ {- $inspect  Parsing an email is nice, but your normally want to get at the-content inside.  One of the most important tasks is __finding entities__-of interest, e.g. attachments, plain text or HTML bodies.  The-'entities' optic is a fold over all /leaf/ entities in the message.-That is, all the non-multipart bodies.  You can use 'filtered' to-refine the query.+content inside.  One of the most important tasks is __finding+entities__ of interest, e.g.  attachments, plain text or HTML+bodies.  The 'entities' optic is a fold over all /leaf/ entities in+the message.  That is, the leaves of (possibly nested) multipart+messages and "message/rfc822" encapsulations.  You can use+'filtered' to refine the query.  For example, let's say you want to find the first @text/plain@ entity in a message.  Define a predicate with the help of the@@ -266,11 +311,9 @@ @ λ> isTextPlain = 'matchContentType' "text" (Just "plain") . view 'contentType' λ> :t isTextPlain-isTextPlain :: HasHeaders s => s -> Bool-λ> isTextPlain msg-True-λ> isTextPlain msg2-False+isTextPlain :: 'HasHeaders' s => s -> Bool+λ> (isTextPlain msg, isTextPlain msg2)+(True,False) @  Now we can use the predicate to construct a fold and retrieve the@@ -281,24 +324,21 @@ Just "Hello, world!" @ -For __attachments__ you are normally interested in the binary data-and possibly the filename (if specified).  In the following example-we retrieve all attachments, and their filenames, as a list of-tuples (although there is only one in the message).  Note that--Get the (optional) filenames and (decoded) body of all attachments,-as a list of tuples.  The 'attachments' optic selects non-multipart-entities with @Content-Disposition: attachment@.  The 'attachments'-fold targets all entities with @Content-Disposition: attachment@.-The 'transferDecoded'' optic undoes the @Content-Transfer-Encoding@-of the entity.+For __attachments__, you may be interested in the binary data and+the filename (if specified).  In the following example we get the+(optional) filenames and (decoded) body of all attachments, as a+list of tuples.  The 'attachments' traversal targets non-multipart+entities with @Content-Disposition: attachment@.  The+'transferDecoded'' optic undoes the @Content-Transfer-Encoding@ of+the entity.  @+λ> :set -XTypeFamilies λ> getFilename = preview ('contentDisposition' . _Just . 'filename' 'defaultCharsets') λ> getBody = preview ('transferDecoded'' . _Right . 'body') λ> getAttachment = liftA2 (,) getFilename getBody λ> toListOf ('attachments' . to getAttachment) msg2-[(Just "data.json",Just "{\"foo\":42}")]+[(Just "data.json",Just "{\\"foo\\":42}")] @  Finally, note that the 'filename' optic takes an argument: it is a@@ -325,15 +365,14 @@ In Australia we say "Hello world" upside down:  @-λ> msg3 = createTextPlainMessage "ɥǝןןo ʍoɹןp"-λ> L.putStrLn $ renderMessage msg3+λ> msg3 = 'createTextPlainMessage' "ɥǝןןo ʍoɹןp"+λ> Data.ByteString.Lazy.Char8.putStrLn $ 'renderMessage' msg3 MIME-Version: 1.0 Content-Transfer-Encoding: base64 Content-Disposition: inline Content-Type: text/plain; charset=utf-8  yaXHndef159vIMqNb8m5159w- @  Charset set and transfer encoding are handled automatically.  If the@@ -356,7 +395,7 @@ λ> text = preview ('transferDecoded'' . _Right . 'charsetText'' 'defaultCharsets' . _Right) ent λ> :t text text :: Maybe T.Text-λ> traverse_ T.putStrLn text+λ> traverse_ Data.Text.IO.putStrLn text ɥǝןןo ʍoɹןp @ @@ -382,13 +421,52 @@ type ByteEntity = Message EncStateByte B.ByteString type TextEntity = Message () T.Text +data MultipartSubtype+  = Mixed+  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.3 RFC 2046 §5.1.3.>+  -- Independent body parts, bundled in a particular order.+  | Alternative+  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.4 RFC 2046 §5.1.4.>+  -- Each part is an alternative version of the same content+  -- (e.g. plain text and HTML), in order of increasing faithfulness+  -- to the original content.+  | Digest+  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.5 RFC 2046 §5.1.5.>+  -- Collection of messages. Parts should have @Content-Type: message/rfc822@.+  | Parallel+  -- ^ <https://www.rfc-editor.org/rfc/rfc2046.html#section-5.1.6 RFC 2046 §5.1.6.>+  -- Independent body parts, order not significants.  Parts may be+  -- displayed in parallel if the system supports it.+  | Related+      ContentType {- ^ @type@ -}+      (Maybe B.ByteString) {- ^ @start@ -}+      (Maybe B.ByteString) {- ^ @start-info@ -}+  -- ^ <https://www.rfc-editor.org/rfc/rfc2387.html RFC 2387.>+  -- Aggregate or compound objects.+  | Signed B.ByteString {- ^ protocol -} B.ByteString {- ^ micalg -}+  -- ^ <https://www.rfc-editor.org/rfc/rfc1847.html#section-2.1 RFC 1847 §2.1.>+  -- Signed messages.+  | Encrypted B.ByteString {- protocol -}+  -- ^ <https://www.rfc-editor.org/rfc/rfc1847.html#section-2.2 RFC 1847 §2.2.>+  | Report B.ByteString {- report-type -}+  -- ^ <https://www.rfc-editor.org/rfc/rfc6522.html RFC 6522>.+  -- Electronic mail reports.+  | Multilingual+  -- ^ <https://www.rfc-editor.org/rfc/rfc8255.html RFC 8255>.+  -- Multilingual messages.  The first part should be a multilingual+  -- explanatory preface.  Subsequent parts MUST have a+  -- @Content-Language@ and a @Content-Type@ field, and MAY have a+  -- @Content-Translation-Type@ field.+  | Unrecognised (CI B.ByteString)+  deriving (Eq, Show)+ -- | MIME message body.  Either a single @Part@, or @Multipart@. -- Only the body is represented; preamble and epilogue are not. -- data MIME   = Part B.ByteString   | Encapsulated MIMEMessage-  | Multipart (NonEmpty MIMEMessage)+  | Multipart MultipartSubtype Boundary (NonEmpty MIMEMessage)   | FailedParse MIMEParseError B.ByteString   deriving (Eq, Show) @@ -407,8 +485,8 @@   Part b ->     (\(Message h' b') -> Message h' (Part b')) <$> f (Message h b)   Encapsulated msg -> Message h . Encapsulated <$> entities f msg-  Multipart bs ->-    Message h . Multipart <$> sequenceA (entities f <$> bs)+  Multipart sub b bs ->+    Message h . Multipart sub b <$> sequenceA (entities f <$> bs)   FailedParse _ _ -> pure (Message h a)  -- | Leaf entities with @Content-Disposition: attachment@@@ -494,12 +572,6 @@ printParameters (Parameters xs) =   foldMap (\(k,v) -> "; " <> CI.original k <> "=" <> v) xs --- | Are the type and subtype the same? (parameters are ignored)----ctEq :: ContentType -> ContentType -> Bool-ctEq (ContentType typ1 sub1 _) = matchContentType typ1 (Just sub1)-{-# DEPRECATED ctEq "Use 'matchContentType' instead" #-}- ctType :: Lens' ContentType (CI B.ByteString) ctType f (ContentType a b c) = fmap (\a' -> ContentType a' b c) (f a) @@ -541,8 +613,26 @@ token =   takeWhile1 (\c -> c >= 33 && c <= 126 && notInClass "()<>@,;:\\\"/[]?=" c) --- | RFC 2046 §4.1.2. defines the default character set to be US-ASCII.+-- | <https://www.rfc-editor.org/rfc/rfc6657.html RFC 6657>+-- specifies that each subtype of the @text@ media type can define+-- its own default value for the @charset@ parameter, including the+-- absense of any default.  It can also specify that the charset+-- information is transported inside the payload (such as in+-- @text/xml@.  Behaviour for common media types includes: --+-- [@text/plain@] Default: @us-ascii@+--   (<https://www.rfc-editor.org/rfc/rfc6657.html#section-4 RFC 6657>)+-- [@text/csv@] Default: @utf-8@+--   (<https://www.rfc-editor.org/rfc/rfc7111.html#section-5.1 RFC 7111>)+-- [@text/markdown@] No default; @charset@ parameter is REQUIRED+--   (<https://www.rfc-editor.org/rfc/rfc7763.html#section-2 RFC 7763>)+-- [@text/enriched@] Default: @us-ascii@+--   (<https://www.rfc-editor.org/rfc/rfc1896.html RFC 1896>)+-- [@text/rtf@] Decoded as @us-ascii@.  Serialised RTF must be 7-bit+--   ASCII, with the character set declared in the payload.+--   Decoding RTF is outside the scope of this library.+--   See <https://www.iana.org/assignments/media-types/text/rtf>.+-- instance HasCharset ByteEntity where   type Decoded ByteEntity = TextEntity   charsetName = to $ \ent ->@@ -553,12 +643,12 @@     in       if typ == "text"       then case source sub of-        InBand f -> f (view body ent)+        InPayload f -> f (view body ent)         InParameter def -> preview l params <|> def-        InBandOrParameter f def -> f (view body ent) <|> preview l params <|> def+        InPayloadOrParameter f -> f (preview l params) (view body ent)       else         preview l params <|> Just "us-ascii"-  charsetData = body -- XXX: do we need to drop the BOM / encoding decl?+  charsetData = body   charsetDecoded m = to $ \a -> (\t -> set body t a) <$> view (charsetText m) a    -- | Encode (@utf-8@) and add/set charset parameter.  If consisting@@ -578,15 +668,18 @@ -- charset should be determined for some media type. -- data EntityCharsetSource-  = InBand (B.ByteString -> Maybe CharsetName)-  -- ^ Charset should be declared within payload (e.g. xml, rtf).-  --   The given function reads it from the payload.+  = InPayload (B.ByteString -> Maybe CharsetName)+  -- ^ Charset should be declared within payload (e.g. rtf).+  --   The given function reads the payload and returns the charset,+  --   or @Nothing@ if the charset cannot be determined or defaulted.   | InParameter (Maybe CharsetName)-  -- ^ Charset should be declared in the @charset@ parameter,+  -- ^ Charset may be declared in the @charset@ parameter,   --   with optional fallback to the given default.-  | InBandOrParameter (B.ByteString -> Maybe CharsetName) (Maybe CharsetName)-  -- ^ Check in-band first, fall back to @charset@ parameter,-  --   and further optionally fall back to a default.+  | InPayloadOrParameter (Maybe CharsetName -> B.ByteString -> Maybe CharsetName)+  -- ^ Charset could be specified in payload or parameter.  The function+  -- parameter takes the value of the charset parameter (which may be @Nothing@+  -- and the payload, and returns the character set that should be used (or+  -- @Nothing@ if a character set cannot be determined or defaulted.  -- | Charset sources for text/* media types.  IANA registry: -- https://www.iana.org/assignments/media-types/media-types.xhtml#text@@ -595,18 +688,21 @@ textCharsetSources =   [ ("plain", InParameter (Just "us-ascii"))   , ("csv", InParameter (Just "utf-8"))-  , ("rtf", InBand (const (Just "us-ascii" {- TODO -})))+  , ("rtf", InPayload (const (Just "us-ascii")))    -- https://tools.ietf.org/html/rfc2854   -- The default is ambiguous; using us-ascii for now-  , ("html", InBandOrParameter (const Nothing {-TODO-}) (Just "us-ascii"))+  , ("html", InPayloadOrParameter (\_param _payload -> Just "us-ascii")) -- FIXME    -- https://tools.ietf.org/html/rfc7763   , ("markdown", InParameter Nothing)    -- https://tools.ietf.org/html/rfc7303#section-3.2 and   -- https://www.w3.org/TR/2008/REC-xml-20081126/#charencoding-  , ("xml", InBand (const (Just "utf-8") {-TODO-}))+  , ("xml", InPayloadOrParameter (\_param _payload -> Just "utf-8")) -- FIXME++  -- https://tools.ietf.org/html/rfc1896.html+  , ("enriched", InParameter (Just "us-ascii"))   ]  -- | @text/plain; charset=us-ascii@@@ -623,11 +719,34 @@ contentTypeApplicationOctetStream =   ContentType "application" "octet-stream" mempty +-- | @multipart/...; boundary=asdf@+contentTypeMultipart :: MultipartSubtype -> Boundary -> ContentType+contentTypeMultipart subtype boundary =+  ContentType "multipart" sub mempty+    & setParam "boundary" (unBoundary boundary)+    & appendParams+  where+    setParam k v = set (parameter k) (Just $ ParameterValue Nothing Nothing v)+    (sub, appendParams) = case subtype of+      Mixed -> ("mixed", id)+      Alternative -> ("alternative", id)+      Digest -> ("digest", id)+      Parallel -> ("parallel", id)+      Multilingual -> ("multilingual", id)+      Report typ -> ("report", setParam "report-type" typ)+      Signed proto micalg -> ("signed", setParam "protocol" proto . setParam "micalg" micalg)+      Encrypted proto -> ("encrypted", setParam "protocol" proto)+      Related typ start startInfo ->+        ( "related"+        , maybe id (setParam "start") start+          . maybe id (setParam "start-info") startInfo+          . setParam "type" (renderContentType typ)+        )+      Unrecognised sub' -> (sub', id)+ -- | @multipart/mixed; boundary=asdf@-contentTypeMultipartMixed :: B.ByteString -> ContentType-contentTypeMultipartMixed boundary =-  set (parameter "boundary") (Just (ParameterValue Nothing Nothing boundary))-  $ ContentType "multipart" "mixed" mempty+contentTypeMultipartMixed :: Boundary -> ContentType+contentTypeMultipartMixed = contentTypeMultipart Mixed  -- | Lens to the content-type header.  Probably not a lawful lens. --@@ -644,6 +763,13 @@ -- otherwise it is added.  Unrecognised Content-Transfer-Encoding -- is ignored when setting. --+-- __Note__: when dealing with 'Multipart' or 'Encapsulated'+-- messages, the @Content-Type@ header will be overridden when+-- serialising the message.  This avoids scenarios where the+-- @Content-Type@ does not match the structure of the message.  In+-- general, the @Content-Type@ header should be treated as "read+-- only" for multipart or encapsulated message.+-- contentType :: HasHeaders a => Lens' a ContentType contentType = headers . lens sa sbt where   sa s = case view cte s of@@ -713,7 +839,7 @@ -- contentDisposition :: HasHeaders a => Lens' a (Maybe ContentDisposition) contentDisposition = headers . at "Content-Disposition" . dimap-  (>>= either (const Nothing) Just . Data.RFC5322.parse parseContentDisposition)+  (>>= either (const Nothing) Just . Data.IMF.parse parseContentDisposition)   (fmap . fmap $ renderContentDisposition)  -- | Traverse the value of the filename parameter (if present).@@ -735,7 +861,7 @@ filenameParameter = parameter "filename"  --- | Get the boundary, if specified+-- | Traversal of @boundary@ parameter (which may be unspecified) mimeBoundary :: Traversal' ContentType B.ByteString mimeBoundary = parameters . rawParameter "boundary" @@ -769,20 +895,48 @@   -> BodyHandler MIME mime' takeTillEnd h = RequiredBody $ case view contentType h of   ct | view ctType ct == "multipart" ->-    case preview (rawParameter "boundary") ct of-      Nothing -> FailedParse MultipartBoundaryNotSpecified <$> takeTillEnd-      Just boundary ->-        (Multipart <$> multipart takeTillEnd boundary)-        <|> (FailedParse MultipartParseFail <$> takeTillEnd)+        case prepMultipart ct of+          Left err              -> FailedParse err <$> takeTillEnd+          Right (sub, boundary) ->+            Multipart sub boundary <$> multipart takeTillEnd boundary+            <|> FailedParse MultipartParseFail <$> takeTillEnd      | matchContentType "message" (Just "rfc822") ct ->         (Encapsulated <$> message (mime' takeTillEnd))         <|> (FailedParse EncapsulatedMessageParseFail <$> takeTillEnd)-  _ -> part+  _ -> Part <$> takeTillEnd   where-    part = Part <$> takeTillEnd+    prepMultipart ct =+      (,) <$> parseSubtype ct <*> parseBoundary ct+    parseBoundary ct =+      getRequiredParam "boundary" ct+      >>= over _Left (InvalidParameterValue "boundary") . makeBoundary+    getRequiredParam k =+      maybe (Left $ RequiredParameterMissing k) Right . preview (rawParameter k)+    getOptionalParam k =+      Right . preview (rawParameter k)+    parseSubtype ct = case view ctSubtype ct of+      "mixed"         -> pure Mixed+      "alternative"   -> pure Alternative+      "digest"        -> pure Digest+      "parallel"      -> pure Parallel+      "multilingual"  -> pure Multilingual+      "report"        -> Report <$> getRequiredParam "report-type" ct+      "signed"        -> Signed+                          <$> getRequiredParam "protocol" ct+                          <*> getRequiredParam "micalg" ct+      "encrypted"     -> Encrypted <$> getRequiredParam "protocol" ct+      "related"       -> Related+                          <$> ( getRequiredParam "type" ct+                              >>= \s -> maybe (Left $ InvalidParameterValue "type" s) Right+                                          (preview (parsed parseContentType) s)+                              )+                          <*> getOptionalParam "start" ct+                          <*> getOptionalParam "start-info" ct+      unrecognised    -> pure $ Unrecognised unrecognised  data MIMEParseError-  = MultipartBoundaryNotSpecified+  = RequiredParameterMissing (CI B.ByteString)+  | InvalidParameterValue (CI B.ByteString) B.ByteString   | MultipartParseFail   | EncapsulatedMessageParseFail   deriving (Eq, Show)@@ -792,14 +946,14 @@ -- multipart   :: Parser B.ByteString  -- ^ parser to the end of the part-  -> B.ByteString         -- ^ boundary, sans leading "--"+  -> Boundary             -- ^ boundary, sans leading "--"   -> Parser (NonEmpty MIMEMessage) multipart takeTillEnd boundary =   skipTillString dashBoundary *> crlf -- FIXME transport-padding   *> fmap fromList (part `sepBy1` crlf)   <* string "--" <* takeTillEnd   where-    delimiter = "\n--" <> boundary+    delimiter = "\n--" <> unBoundary boundary     dashBoundary = B.tail delimiter     part = message (mime' (trim <$> takeTillString delimiter))     trim s  -- trim trailing CR, because we only searched for LF@@ -810,116 +964,54 @@ -- | Sets the @MIME-Version: 1.0@ header. -- instance RenderMessage MIME where-  tweakHeaders = set (headers . at "MIME-Version") (Just "1.0")-  buildBody h z = Just $ case z of+  tweakHeaders b h =+    h+    & set (headers . at "MIME-Version") (Just "1.0")+    & setContentType+    where+      setContentType = case b of+        Multipart sub boundary _  -> set contentType (contentTypeMultipart sub boundary)+        Encapsulated _msg         -> set contentType "message/rfc822"+        _                         -> id+  buildBody _h z = Just $ case z of     Part partbody -> Builder.byteString partbody     Encapsulated msg -> buildMessage msg-    Multipart xs ->-      let b = firstOf (contentType . mimeBoundary) h-          boundary = maybe mempty (\b' -> "--" <> Builder.byteString b') b+    Multipart _sub b xs ->+      let+        boundary = "--" <> Builder.byteString (unBoundary b)       in         boundary <> "\r\n"         <> fold (intersperse ("\r\n" <> boundary <> "\r\n") (fmap buildMessage xs))         <> "\r\n" <> boundary <> "--\r\n"     FailedParse _ bs -> Builder.byteString bs ----- | 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 f g k =-  headers . at k . iso (maybe [] f) (\l -> if null l then Nothing else Just (g l))--headerFrom :: HasHeaders a => CharsetLookup -> Lens' a [Mailbox]-headerFrom charsets = headerSingleToList-  (fromRight [] . parseOnly (mailboxList charsets))-  renderMailboxes-  "From"--headerAddressList :: (HasHeaders a) => CI B.ByteString -> CharsetLookup -> Lens' a [Address]-headerAddressList k charsets = headerSingleToList-  (fromRight [] . parseOnly (addressList charsets))-  renderAddresses-  k--headerTo, headerCC, headerBCC :: (HasHeaders a) => CharsetLookup -> Lens' a [Address]-headerTo = headerAddressList "To"-headerCC = headerAddressList "Cc"-headerBCC = headerAddressList "Bcc"--headerDate :: HasHeaders a => Lens' a (Maybe UTCTime)-headerDate = headers . at "Date" . iso (parseDate =<<) (fmap renderRFC5422Date)-  where-    parseDate =-        parseTimeM True defaultTimeLocale rfc5422DateTimeFormatLax . C8.unpack---- | Single-valued header with @Text@ value via encoded-words.--- The conversion to/from Text is total (encoded-words that failed to be--- decoded are passed through unchanged).  Therefore @Nothing@ means that--- the header was not present.------ This function is suitable for the @Subject@ header.----headerText :: (HasHeaders a) => CharsetLookup -> CI B.ByteString -> Lens' a (Maybe T.Text)-headerText charsets k =-  headers . at k . iso (fmap (decodeEncodedWords charsets)) (fmap encodeEncodedWords)---- | Subject header.  See 'headerText' for details of conversion to @Text@.-headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)-headerSubject charsets = headerText charsets "Subject"----- | Returns a space delimited `B.ByteString` with values from identification--- fields from the parents message `Headers`. Rules to gather the values are in--- accordance to RFC5322 - 3.6.4 as follows sorted by priority (first has--- precedence):------ * Values from @References@ and @Message-ID@ (if any)--- * Values from @In-Reply-To@ and @Message-ID@ (if any)--- * Value from @Message-ID@ (in case it's the first reply to a parent mail)--- * Otherwise @Nothing@ is returned indicating that the replying mail should---   not have a @References@ field.----replyHeaderReferences :: HasHeaders a => Getter a (Maybe C8.ByteString)-replyHeaderReferences = (.) headers $ to $ \hdrs ->-  let xs = catMaybes-        [preview (header "references") hdrs-         <|> preview (header "in-reply-to") hdrs-        , preview (header "message-id") hdrs-        ]-  in if null xs then Nothing else Just (B.intercalate " " xs)- -- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple -- `attachments` -- createMultipartMixedMessage-    :: B.ByteString -- ^ Boundary+    :: Boundary     -> NonEmpty MIMEMessage -- ^ parts     -> MIMEMessage createMultipartMixedMessage b attachments' =-    let hdrs = mempty &-                set contentType (contentTypeMultipartMixed b)-    in Message hdrs (Multipart attachments')+  let hdrs = Headers [] & set contentType (contentTypeMultipartMixed b)+  in Message hdrs (Multipart Mixed b attachments')  -- | Create an inline, text/plain, utf-8 encoded message -- createTextPlainMessage :: T.Text -> MIMEMessage-createTextPlainMessage s = fmap Part $ transferEncode $ charsetEncode msg-  where-  msg = Message hdrs s :: TextEntity-  cd = ContentDisposition Inline mempty-  hdrs = mempty-          & set contentType contentTypeTextPlain-          & set contentDisposition (Just cd)+createTextPlainMessage s = setTextPlainBody s (Message (Headers []) ()) +-- | Set an inline, @text/plain@, utf-8 encoded message body+--+setTextPlainBody :: T.Text -> Message ctx a -> MIMEMessage+setTextPlainBody s =+  fmap Part+  . transferEncode+  . charsetEncode+  . set contentDisposition (Just $ ContentDisposition Inline mempty)+  . set contentType contentTypeTextPlain+  . set body s+ -- | Create an attachment from a given file path. -- Note: The filename content disposition is set to the given `FilePath`. For -- privacy reasons, you can unset/change it. See `filename` for examples.@@ -936,7 +1028,7 @@   msg = Message hdrs s   cd = ContentDisposition Attachment cdParams   cdParams = mempty & set filenameParameter (newParameter <$> fp)-  hdrs = mempty+  hdrs = Headers []           & set contentType ct           & set contentDisposition (Just cd) @@ -946,4 +1038,4 @@ encapsulate :: MIMEMessage -> MIMEMessage encapsulate = Message hdrs . Encapsulated   where-  hdrs = mempty & set contentType "message/rfc822"+  hdrs = Headers [] & set contentType "message/rfc822"

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2017-2020  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+ {-# LANGUAGE OverloadedStrings #-}  {- |@@ -46,7 +62,7 @@ contentTransferEncodeBase64 = L.toStrict . wrap . L64.encode . L.fromStrict   where   wrap s = case L.splitAt 76 s of-    ("", _) -> ""+    (l, "") -> l     (l, s') -> l <> "\r\n" <> wrap s'  {-

@@ -0,0 +1,79 @@+-- This file is part of purebred-email+-- Copyright (C) 2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module Data.MIME.Boundary+  (+    Boundary+  , unBoundary+  , makeBoundary+  ) where++import Control.Monad (replicateM)++import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import Data.ByteString.Char8 as C8+import System.Random.Stateful++-- | MIME boundary.  Use 'makeBoundary' to construct, and 'unBoundary'+-- to unwrap.+--+-- Use the 'Uniform' instance to generate a random @Boundary@ to use+-- when constructing messages.  For example:+--+-- @+-- 'getStdRandom' 'uniform' :: MonadIO m =>  m Boundary+-- 'getStdRandom' 'uniform' ::              IO Boundary+-- @+--+newtype Boundary = Boundary B.ByteString+  deriving (Eq, Show)++unBoundary :: Boundary -> B.ByteString+unBoundary (Boundary s) = s++-- Boundary smart constructor that checks validity+makeBoundary :: B.ByteString -> Either B.ByteString Boundary+makeBoundary s+  | B.null s                    = Left s+  | B.length s > 70             = Left s+  | B.any (not . validBchar) s  = Left s+  | B.last s == 0x20            = Left s+  | otherwise                   = Right $ Boundary s+  where+    validBchar c =+      c >= 0x2c && c <= 0x3a -- ',', '-', '.', '/', '0'..'9', ':'+      || c >= 0x41 && c <= 0x5a -- 'A'..'Z'+      || c >= 0x61 && c <= 0x7a -- 'a'..'z'+      || c >= 0x27 && c <= 0x29 -- '\'', '(', ')'+      || c == 0x2b {- '+' -}+      || c == 0x5f {- '_' -}+      || c == 0x3d {- '=' -}+      || c == 0x3f {- '?' -}+      || c == 0x20 {- ' ' -}++-- | Generate a random 'Boundary'+genBoundary :: (StatefulGen g m) => g -> m Boundary+genBoundary g = do+  let+    blen = 64+    bchars = C8.pack $ ['0'..'9'] <> ['a'..'z'] <> ['A'..'Z'] <> "'()+_,-./:=?"+  chars <-+    replicateM blen $ B.index bchars <$> uniformRM (0, B.length bchars - 1) g+  pure . Boundary $ B.unsafePackLenBytes blen chars++instance Uniform Boundary where+  uniformM = genBoundary

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2018-2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -129,16 +145,52 @@   , ("utf-8", utf_8)   , ("iso-8859-1", iso_8859_1) -  -- uncommon aliases+  -- us-ascii aliases   , ("ISO646-US", us_ascii)   , ("ANSI_X3.4-1968", us_ascii)+  , ("iso-ir-6", us_ascii)+  , ("ANSI_X3.4-1986", us_ascii)+  , ("ISO_646.irv:1991", us_ascii)+  , ("us", us_ascii)+  , ("IBM367", us_ascii)+  , ("cp367", us_ascii)+  , ("csASCII.4-1968", us_ascii) +  -- iso-8859-1 aliases+  , ("iso-ir-100", iso_8859_1)+  , ("ISO_8859-1", iso_8859_1)+  , ("latin1", iso_8859_1)+  , ("l1", iso_8859_1)+  , ("IBM819", iso_8859_1)+  , ("CP819", iso_8859_1)+  , ("csISOLatin1", iso_8859_1)++  -- utf-8 aliases+  , ("csUTF8", utf_8)++  -- utf-16+  , ("UTF-16BE", utf16be)+  , ("UTF-16LE", utf16le)+  , ("UTF-16", utf16)+  , ("csUTF16BE", utf16be)+  , ("csUTF16LE", utf16le)+  , ("csUTF16", utf16)++  -- utf-32+  , ("UTF-32BE", utf32be)+  , ("UTF-32LE", utf32le)+  , ("UTF-32", utf32)+  , ("csUTF32BE", utf32be)+  , ("csUTF32LE", utf32le)+  , ("csUTF32", utf32)++  -- Other charsets I observed in my mail corpus.   -- , ("iso-8859-2", ...)   -- , ("iso-8859-15", ...)   -- , ("iso-2022-jp", ...)    (common)   -- , ("windows-1252", ...)   (common)   -- , ("windows-1256", ...)-  -- , ("cp1252", ...)         (same as windows-1256?)+  -- , ("cp1252", ...)         (alias of windows-1252)   -- , ("big5", ...)           (common)   -- , ("euc-kr", ...)   -- , ("cp932", ...)@@ -150,10 +202,29 @@ utf_8 = decodeLenient iso_8859_1 = T.decodeLatin1 +utf16be, utf16le, utf16 :: Charset+utf16be = T.decodeUtf16BEWith T.lenientDecode+utf16le = T.decodeUtf16LEWith T.lenientDecode+-- https://www.rfc-editor.org/rfc/rfc2781.html#section-4.3+utf16 b = case B.take 2 b of+  "\xff\xfe"  -> utf16le b+  _           -> utf16be b +utf32be, utf32le, utf32 :: Charset+utf32be = T.decodeUtf32BEWith T.lenientDecode+utf32le = T.decodeUtf32LEWith T.lenientDecode+-- Unicode 4.0, Section 3.10, D45+-- https://www.unicode.org/versions/Unicode4.0.0/ch03.pdf#G7404+utf32 b = case B.take 4 b of+  "\xff\xfe\x00\x00"  -> utf32le b+  _                   -> utf32be b++ type CharsetLookup = CI.CI B.ByteString -> Maybe Charset --- | Supports US-ASCII, UTF-8 and ISO-8859-1.+-- | Supports US-ASCII, UTF-8 and ISO-8859-1, UTF-16[BE|LE]+-- and UTF-32[BE|LE].  The /purebred-icu/ package provides+-- support for more charsets. -- defaultCharsets :: CharsetLookup defaultCharsets k = lookup k charsets

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2018-2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -38,7 +54,7 @@ import Data.MIME.TransferEncoding import Data.MIME.Base64 import Data.MIME.QuotedPrintable-import Data.RFC5322.Internal (ci, takeTillString)+import Data.IMF.Syntax (ci, takeTillString)  data EncodedWord = EncodedWord   { _encodedWordCharset :: CI.CI B.ByteString

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

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

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2018-2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}@@ -60,7 +76,7 @@  import Data.MIME.Charset import Data.MIME.Internal-import Data.RFC5322.Internal (ci, isQtext, isVchar)+import Data.IMF.Syntax (ci, isQtext, isVchar)  type RawParameters = [(CI B.ByteString, B.ByteString)] -- | Header parameters.  Used for some headers including Content-Type

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

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

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

@@ -1,523 +1,21 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--{- |--Email messages.  Deals specifically with RFC 5322, which is stricter-than RFC 822 or RFC 2822.  If you have to deal with messages that-comply with the older specifications but not RFC 5322, preprocess-the input and massage it to be RFC 5322 compliant.--This parser allows LF line endings in addition to CRLF (RFC 5322-demands CRLF but LF-only is common in on-disk formats).--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' :: Lens' (Message ctx a) Headers-'header' :: CI B.ByteString -> Fold 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-      B.putStrLn $ "subject: " <> foldOf ('headers' . 'header' "subject") msg-      putStrLn $ "num headers: " <> show (length (view 'headers' msg))-      putStrLn $ "body length: " <> show (B.length (view 'body' msg))-@---}-module Data.RFC5322-  (-  -- * Message types-    Message(..)-  , message-  , MessageContext-  , BodyHandler(..)-  , body-  , EqMessage(..)--  -- ** Headers-  , Header-  , HasHeaders(..)-  , header-  , headerList-  , Headers(..)--  -- ** Addresses-  , Address(..)-  , address-  , addressList-  , AddrSpec(..)-  , Domain(..)-  , Mailbox(..)-  , mailbox-  , mailboxList--  -- * Parsers-  , parse-  , parsed-  , parsePrint-  , crlf-  , quotedString--  -- * Helpers-  , field-  , rfc5422DateTimeFormat-  , rfc5422DateTimeFormatLax--  -- * Serialisation-  , buildMessage-  , renderMessage-  , RenderMessage(..)-  , renderRFC5422Date-  , buildFields-  , buildField-  , renderAddressSpec-  , renderMailbox-  , renderMailboxes-  , renderAddress-  , renderAddresses-  ) where--import Control.Applicative-import Data.Foldable (fold)-import Data.List (findIndex, intersperse)-import Data.List.NonEmpty (intersperse)-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.Clock (UTCTime)-import Data.Time.Format (defaultTimeLocale, formatTime)--import Data.RFC5322.Internal-  ( CI, ci, original-  , (<<>>), foldMany, foldMany1Sep-  , fromChar, isAtext, isQtext, isVchar, isWsp-  , optionalCFWS, word, wsp, vchar, optionalFWS, crlf-  , domainLiteral, dotAtom, localPart, quotedString-  )-import Data.RFC5322.Address.Types-import Data.MIME.Charset-import Data.MIME.EncodedWord (encodedWord, decodeEncodedWord, buildEncodedWord)-import Data.MIME.TransferEncoding (transferEncode)--type Header = (CI B.ByteString, B.ByteString)-newtype Headers = Headers [Header]-  deriving (Eq, Show, Generic, NFData)--instance Semigroup Headers where-  Headers a <> Headers b = Headers (a <> b)--instance Monoid Headers where-  mempty = Headers []--class HasHeaders a where-  headers :: Lens' a Headers--instance HasHeaders Headers where-  headers = id--type instance Index Headers = CI B.ByteString-type instance IxValue Headers = B.ByteString--instance Ixed Headers where-  ix = header--hdriso :: Iso' Headers [(CI B.ByteString, B.ByteString)]-hdriso = iso (\(Headers xs) -> xs) Headers---- | Acts upon the first occurrence of the header only.----instance At Headers where-  at k = hdriso . l-    where-    l :: Lens' [(CI B.ByteString, B.ByteString)] (Maybe B.ByteString)-    l f kv =-      let-        i = findIndex ((== k) . fst) kv-        g Nothing = maybe kv (\j -> take j kv <> drop (j + 1) kv) i-        g (Just v) = maybe ((k,v):kv) (\j -> set (ix j) (k,v) kv) i-      in-        g <$> f (lookup k kv)----- | Target all values of the given header-header :: HasHeaders a => CI B.ByteString -> Traversal' a B.ByteString-header k = headerList . traversed . filtered ((k ==) . fst) . _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 (Show, Generic, NFData)--instance HasHeaders (Message s a) where-  headers f (Message h b) = fmap (`Message` b) (f h)--instance Functor (Message s) where-  fmap f (Message h a) = Message h (f 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 h1 b1) (Message h2 b2) = h1 == h2 && b1 == b2---instance EqMessage a => Eq (Message s a) where-  (==) = eqMessage---- | Access headers as a list of key/value pairs.-headerList :: HasHeaders a => Lens' a [(CI B.ByteString, B.ByteString)]-headerList = headers . coerced--body :: Lens (Message ctx a) (Message ctx' b) a b-body f (Message h b) = fmap (\b' -> Message h b') (f b)-{-# ANN body ("HLint: ignore Avoid lambda" :: String) #-}--isSpecial :: Word8 -> Bool-isSpecial = inClass "()<>[]:;@\\,.\""--special :: Parser Word8-special = satisfy isSpecial----- §3.3  Date and Time Specification--- Sat, 29 Sep 2018 12:51:05 +1000-rfc5422DateTimeFormat :: String-rfc5422DateTimeFormat = "%a, %d %b %Y %T %z"--rfc5422DateTimeFormatLax :: String-rfc5422DateTimeFormatLax = "%a, %-d %b %Y %-H:%-M:%-S %z"--renderRFC5422Date :: UTCTime -> B.ByteString-renderRFC5422Date = Char8.pack . formatTime defaultTimeLocale rfc5422DateTimeFormat---- §3.4 Address Specification-buildMailbox :: Mailbox -> Builder.Builder-buildMailbox (Mailbox n a) =-  maybe a' (\n' -> buildPhrase n' <> " <" <> a' <> ">") n-  where-    a' = buildAddressSpec 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 "" = "\"\""-buildPhrase s =-  case enc s of-    PhraseAtom -> T.encodeUtf8Builder s-    PhraseQuotedString -> qsBuilder False-    PhraseQuotedStringEscapeSpace -> qsBuilder True-    PhraseEncodedWord -> buildEncodedWord . transferEncode . charsetEncode $ s-  where-    enc = snd . T.foldr (\c (prev, req) -> (c, encChar prev c <> req)) ('\0', mempty)-    encChar prev c-      | isAtext c = PhraseAtom-      | isQtext c = PhraseQuotedString-      | isVchar c = PhraseQuotedString-      | c == ' ' =-          if prev == ' '  -- two spaces in a row; need to avoid FWS-          then PhraseQuotedStringEscapeSpace-          else PhraseQuotedString-      | otherwise = PhraseEncodedWord--    qsBuilder escSpace = "\"" <> T.encodeUtf8BuilderEscaped (escPrim escSpace) s <> "\""-    escPrim escSpace = Prim.condB (\c -> isQtext c || not escSpace && c == 32)-      (Prim.liftFixedToBounded Prim.word8)-      (Prim.liftFixedToBounded $ (fromChar '\\',) Prim.>$< Prim.word8 Prim.>*< Prim.word8)---- | Data type used to compute escaping requirement of a Text 'phrase'----data PhraseEscapeRequirement-  = PhraseAtom-  | PhraseQuotedString-  | PhraseQuotedStringEscapeSpace-  | PhraseEncodedWord-  deriving (Eq, Ord)--instance Semigroup PhraseEscapeRequirement where-  PhraseEncodedWord <> _ =-    -- allows early termination of folds-    PhraseEncodedWord-  l <> r = max l r--instance Monoid PhraseEscapeRequirement where-  mempty = PhraseAtom----renderMailboxes :: [Mailbox] -> B.ByteString-renderMailboxes = L.toStrict . Builder.toLazyByteString . buildMailboxes--buildMailboxes :: [Mailbox] -> Builder.Builder-buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox--renderMailbox :: Mailbox -> B.ByteString-renderMailbox = L.toStrict . Builder.toLazyByteString . buildMailbox--mailbox :: CharsetLookup -> Parser Mailbox-mailbox charsets =-  Mailbox <$> optional (displayName charsets) <*> angleAddr-  <|> Mailbox Nothing <$> addressSpec--phrase :: CharsetLookup -> Parser T.Text-phrase charsets = foldMany1Sep " " $-  fmap (decodeEncodedWord charsets) ("=?" *> encodedWord)-  <|> fmap decodeLenient word--displayName :: CharsetLookup -> Parser T.Text-displayName = phrase--angleAddr :: Parser AddrSpec-angleAddr = optionalCFWS *>-  char8 '<' *> addressSpec <* char8 '>'-  <* optionalCFWS--buildAddressSpec :: AddrSpec -> Builder.Builder-buildAddressSpec (AddrSpec lp (DomainDotAtom b))-  | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest-  | otherwise = buildLP <> rest-  where-    buildLP = Builder.byteString lp-    rest = "@" <> foldMap Builder.byteString (Data.List.NonEmpty.intersperse "." b)-buildAddressSpec (AddrSpec lp (DomainLiteral b)) =-  foldMap Builder.byteString [lp, "@", b]--renderAddressSpec :: AddrSpec -> B.ByteString-renderAddressSpec = L.toStrict . Builder.toLazyByteString . buildAddressSpec--addressSpec :: Parser AddrSpec-addressSpec = AddrSpec <$> localPart <*> (char8 '@' *> domain)---- | Printable US-ASCII excl "[", "]", or "\"-isDtext :: Word8 -> Bool-isDtext c = (c >= 33 && c <= 90) || (c >= 94 && c <= 126)--domain :: Parser Domain-domain = (DomainDotAtom <$> dotAtom)-         <|> (DomainLiteral <$> domainLiteral)--mailboxList :: CharsetLookup -> Parser [Mailbox]-mailboxList charsets = mailbox charsets `sepBy` char8 ','--renderAddresses :: [Address] -> B.ByteString-renderAddresses xs = B.intercalate ", " $ renderAddress <$> xs--renderAddress :: Address -> B.ByteString-renderAddress (Single m) = renderMailbox m-renderAddress (Group name xs) = T.encodeUtf8 name <> ":" <> renderMailboxes xs <> ";"--addressList :: CharsetLookup -> Parser [Address]-addressList charsets = address charsets `sepBy` char8 ','--group :: CharsetLookup -> Parser Address-group charsets =-  Group <$> displayName charsets <* char8 ':'-        <*> mailboxList charsets <* char8 ';' <* optionalCFWS--address :: CharsetLookup -> Parser Address-address charsets =-  group charsets <|> Single <$> mailbox charsets---- §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 f = fields >>= \hdrs -> Message hdrs <$> case f hdrs of-  RequiredBody b -> crlf *> b-  OptionalBody (b, a) -> optional crlf >>= maybe (pure a) (const b)-  NoBody b -> pure b--type family MessageContext a---fields :: Parser Headers-fields = Headers <$> many 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 :: Headers -> Headers-  tweakHeaders = 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 h b) =-  buildFields (tweakHeaders @a h)-  <> maybe mempty ("\r\n" <>) (buildBody h 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 = Builder.toLazyByteString . buildMessage---- Header serialisation-buildFields :: Headers -> Builder.Builder-buildFields = foldMapOf (hdriso . traversed) buildField--buildField :: (CI B.ByteString, B.ByteString) -> Builder.Builder-buildField (k,v) =-  let key = original k-  in-    Builder.byteString key-    <> ":"-    <> foldUnstructured v (B.length key + 1)-    <> "\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.+-- This file is part of purebred-email+-- Copyright (C) 2021  Fraser Tweedale ---foldUnstructured :: B.ByteString -> Int -> Builder.Builder-foldUnstructured s i = case Char8.words s of-  [] -> mempty-  (h:t) ->-    -- Special case to prevent wrapping of first word;-    -- see 6dbc04fb1863e845699b1cef50f4edaf1326bdae for info.-    " " <> Builder.byteString h <> go t (i + 1 + B.length h)-  where-  limit = 76  -- could be 78, but this preserves old behaviour-  go [] _ = mempty-  go (chunk:chunks) col-    | col + 1 + B.length chunk < limit =-        -- there is room for the chunk-        " " <> Builder.byteString chunk <> go chunks (col + 1 + B.length chunk)-    | col <= 1 =-        -- there isn't room for the chunk, but we are at the-        -- beginning of the line so add it here anyway (otherwise-        -- we will add "\r\n" and recurse forever-        " " <> Builder.byteString chunk <> "\r\n" <> go chunks 0-    | otherwise = "\r\n" <> go (chunk:chunks) 0  -- fold---- | Printable ASCII excl. ':'-isFtext :: Word8 -> Bool-isFtext c = (c >= 33 && c <= 57) || (c >= 59 && c <= 126)--field :: Parser (CI B.ByteString, B.ByteString)-field = (,)-  <$> ci (takeWhile1 isFtext)-  <*  char8 ':' <* many wsp-  <*> unstructured <* crlf--unstructured :: Parser B.ByteString-unstructured =-  foldMany (optionalFWS <<>> (B.singleton <$> vchar))-  <<>> A.takeWhile isWsp----- | Given a parser, construct a 'Fold'+-- 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. ----- See 'parse' for discussion of performance.+-- 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. ---parsed :: (Cons s s Word8 Word8) => Parser a -> Fold s a-parsed p = to (parse p) . folded-{-# INLINE parsed #-}+-- 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/>. --- | Construct a prism from a parser and a printer-parsePrint :: Parser a -> (a -> B.ByteString) -> Prism' B.ByteString a-parsePrint fwd rev = prism' rev (AL.maybeResult . AL.parse fwd . view recons)+module Data.RFC5322+  {-# DEPRECATED "Use \"Data.IMF\" instead" #-}+  ( module X ) where --- | 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 p = AL.eitherResult . AL.parse p . view recons-{-# INLINE parse #-}+import Data.IMF as X

@@ -1,110 +1,21 @@-{-# LANGUAGE OverloadedStrings #-}-{- |--Parser for roundtripping Text based `Mailbox`es and addresses.+-- This file is part of purebred-email+-- Copyright (C) 2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. --} module Data.RFC5322.Address.Text-  (-    mailbox-  , mailboxList-  , address-  , addressList-  -- * Pretty printing-  , renderMailbox-  , renderMailboxes-  , renderAddress-  , renderAddresses-  , renderAddressSpec-  ) where--import Control.Applicative ((<|>), optional)-import Data.Foldable (fold)-import Data.List (intersperse)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Internal.Builder as Builder-import qualified Data.ByteString as B-import Data.Attoparsec.Text as A hiding (parse, take)-import Data.List.NonEmpty (intersperse)--import Data.MIME.Charset (decodeLenient)-import Data.RFC5322.Address.Types-import Data.RFC5322.Internal---renderMailboxes :: [Mailbox] -> T.Text-renderMailboxes = LT.toStrict . Builder.toLazyText . buildMailboxes--buildMailboxes :: [Mailbox] -> Builder.Builder-buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox--renderMailbox :: Mailbox -> T.Text-renderMailbox = LT.toStrict . Builder.toLazyText . buildMailbox---- | Printing function to "pretty print" the mailbox for display purposes-buildMailbox :: Mailbox -> Builder.Builder-buildMailbox (Mailbox n a) =-  maybe a' (\n' -> "\"" <> Builder.fromText n' <> "\" " <> "<" <> a' <> ">") n-  where-    a' = buildAddressSpec a--renderAddresses :: [Address] -> T.Text-renderAddresses xs = T.intercalate ", " $ renderAddress <$> xs--renderAddress :: Address -> T.Text-renderAddress (Single m) = renderMailbox m-renderAddress (Group name xs) = name <> ":" <> renderMailboxes xs <> ";"--buildAddressSpec :: AddrSpec -> Builder.Builder-buildAddressSpec (AddrSpec lp (DomainDotAtom b))-  | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest-  | otherwise = buildLP <> rest-  where-    buildLP = Builder.fromText $ decodeLenient lp-    rest = "@" <> foldMap Builder.fromText (decodeLenient <$> Data.List.NonEmpty.intersperse "." b)-buildAddressSpec (AddrSpec lp (DomainLiteral b)) =-  foldMap Builder.fromText [decodeLenient lp, "@", decodeLenient b]--renderAddressSpec :: AddrSpec -> T.Text-renderAddressSpec = LT.toStrict . Builder.toLazyText . buildAddressSpec----- §3.4 Address Specification-mailbox :: Parser Mailbox-mailbox = Mailbox <$> optional displayName <*> angleAddr-          <|> Mailbox Nothing <$> addressSpec---- | Version of 'phrase' that does not process encoded-word--- (we are parsing Text so will assume that the input does not--- contain encoded words.  TODO this is probably wrong :)-phrase :: Parser T.Text-phrase = foldMany1Sep (singleton ' ') word--displayName :: Parser T.Text-displayName = phrase--mailboxList :: Parser [Mailbox]-mailboxList = mailbox `sepBy` char ','--addressList :: Parser [Address]-addressList = address `sepBy` char ','--group :: Parser Address-group = Group <$> displayName <* char ':' <*> mailboxList <* char ';' <* optionalCFWS--address :: Parser Address-address = group <|> Single <$> mailbox--angleAddr :: Parser AddrSpec-angleAddr = optionalCFWS *>-  char '<' *> addressSpec <* char '>'-  <* optionalCFWS--addressSpec :: Parser AddrSpec-addressSpec = AddrSpec <$> (T.encodeUtf8 <$> localPart) <*> (char '@' *> domain)+  {-# DEPRECATED "Use \"Data.IMF.Text\" instead" #-}+  ( module X ) where -domain :: Parser Domain-domain = (DomainDotAtom . fmap T.encodeUtf8 <$> dotAtom)-         <|> (DomainLiteral . T.encodeUtf8 <$> domainLiteral)+import Data.IMF.Text as X

@@ -1,7 +1,21 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+-- This file is part of purebred-email+-- Copyright (C) 2021  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.  module Data.RFC5322.Address.Types+  {-# DEPRECATED "Use \"Data.IMF\" instead" #-}   (     Mailbox(..)   , Address(..)@@ -9,29 +23,4 @@   , Domain(..)   ) where -import Control.DeepSeq (NFData)-import qualified Data.Text as T-import qualified Data.ByteString as B-import Data.List.NonEmpty (NonEmpty)-import GHC.Generics (Generic)--data Mailbox =-    Mailbox (Maybe T.Text {- display name -})-             AddrSpec-    deriving (Show, Eq, Generic, NFData)--data AddrSpec =-    AddrSpec B.ByteString {- local part -}-             Domain-    deriving (Show, Eq, Generic, NFData)--data Address-    = Single Mailbox-    | Group T.Text {- display name -}-            [Mailbox]-    deriving (Show, Eq, Generic, NFData)--data Domain-    = DomainDotAtom (NonEmpty B.ByteString {- printable ascii -})-    | DomainLiteral B.ByteString-    deriving (Show, Eq, Generic, NFData)+import Data.IMF

@@ -1,378 +1,21 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.RFC5322.Internal-  (-  -- * Case-insensitive value parsers-    ci-  , CI-  , original--  -- * Abstract character parsers-  , wsp-  , optionalFWS-  , optionalCFWS-  , crlf-  , vchar-  , word-  , quotedString-  , dotAtom-  , localPart-  , domainLiteral-  , IsChar(..)-  , CharParsing(..)-  , SM--  -- ** Helpers for building parsers-  , isAtext-  , isQtext-  , isVchar-  , isWsp--  -- * Semigroup and monoid folding combinators-  , (<<>>)-  , foldMany-  , foldMany1-  , foldMany1Sep--  -- * General parsers and combinators-  , skipTill-  , takeTill'--  -- * Efficient string search-  , skipTillString-  , takeTillString--  ) where--import Prelude hiding (takeWhile)-import Control.Applicative ((<|>), Alternative, liftA2, many, optional)-import Control.Monad (void)-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.Internal as A-import qualified Data.Attoparsec.Internal.Types as AT-import qualified Data.Attoparsec.Text as AText-import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import Data.ByteString.Search (indices)-import Data.CaseInsensitive (CI, FoldCase, mk, original)-import Data.Char (chr)-import Data.Foldable (fold)-import Data.Functor (($>))-import Data.List.NonEmpty (NonEmpty, fromList, intersperse)-import Data.Semigroup.Foldable (fold1)-import qualified Data.Text as T-import Data.Word (Word8)----- | Constraint synonym to handle the Semigroup Monoid Proposal--- transition gracefully.-#if MIN_VERSION_base(4,11,0)-type SM a = Monoid a-#else-type SM a = (Semigroup a, Monoid a)-#endif--class IsChar a where-  toChar :: a -> Char-  fromChar :: Char -> a--instance IsChar Char where-  toChar = id-  fromChar = id--instance IsChar Word8 where-  toChar = w2c-  fromChar = c2w--class IsChar a => CharParsing f s a | s -> a, a -> f s where-  singleton :: Char -> s-  satisfy :: (Char -> Bool) -> (f s) a-  takeWhile :: (Char -> Bool) -> (f s) s-  takeWhile1 :: (Char -> Bool) -> (f s) s--instance CharParsing AT.Parser B.ByteString Word8 where-  singleton = B.singleton . c2w-  satisfy f = A.satisfy (f . w2c)-  takeWhile f = A.takeWhile (f . w2c)-  takeWhile1 f = A.takeWhile1 (f . w2c)--instance CharParsing AT.Parser T.Text Char where-  singleton = T.singleton-  satisfy = AText.satisfy-  takeWhile = AText.takeWhile-  takeWhile1 = AText.takeWhile1--char :: CharParsing f s a => Char -> (f s) a-char c = satisfy (== c)--isWsp :: IsChar c => c -> Bool-isWsp = AText.inClass "\t " . toChar--wsp :: CharParsing f s a => (f s) a-wsp = satisfy isWsp--isVchar :: IsChar c => c -> Bool-isVchar c =-  let c' = toChar c-  in c' >= chr 0x21 && c' <= chr 0x7e--vchar :: CharParsing f s a => (f s) a-vchar = satisfy isVchar--dquote :: CharParsing f s a => (f s) a-dquote = char '"'--quotedPair :: (Alternative (f s)) => CharParsing f s a => (f s) a-quotedPair = char '\\' *> (vchar <|> wsp)---- §3.2.4.  Quoted Strings--isQtext :: IsChar c => c -> Bool-isQtext c' =-  let c = toChar c'-  in-    c == chr 33-    || (c >= chr 35 && c <= chr 91)-    || (c >= chr 93 && c <= chr 126)--quotedString :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-quotedString =-  optionalCFWS *> dquote-  *> foldMany (optionalFWS <<>> qcontent) <<>> optionalFWS-  <* dquote <* optionalCFWS-  where-    qcontent =-      (singleton . toChar <$> satisfy isQtext)-      <|> (singleton . toChar <$> quotedPair)--isAtext :: IsChar c => c -> Bool-isAtext = AText.inClass "-A-Za-z0-9!#$%&'*+/=?^_`{|}~" . toChar--atext :: CharParsing f s a => (f s) a-atext = satisfy isAtext---- | Either CRLF or LF (lots of mail programs transform CRLF to LF)-crlf :: (Alternative (f s)) => CharParsing f s a => (f s) ()-crlf = void ((char '\r' *> char '\n') <|> char '\n')---- §3.2.2.  Folding White Space and Comments------ "The general rule is that wherever this specification allows for folding--- white space (not simply WSP characters), a CRLF may be inserted before any--- WSP."--fws :: (Alternative (f s), CharParsing f s a) => (f s) s-fws = ( optional (takeWhile isWsp *> crlf) *> takeWhile1 isWsp )-      $> singleton ' '---- | FWS collapsed to a single SPACE character, or empty string----optionalFWS :: (Alternative (f s), CharParsing f s a, Monoid s) => (f s) s-optionalFWS = fws <|> pure mempty---- | Printable ASCII excl. '(', ')', '\'-isCtext :: Char -> Bool-isCtext c =-  c >= chr 33 && c <= chr 39-  || c >= chr 42 && c <= chr 91-  || c >= chr 93 && c <= chr 126--ccontent :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-ccontent = (singleton . toChar <$> satisfy isCtext) <|> comment--comment :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-comment =-  char '(' *> foldMany (optionalFWS <<>> ccontent) <* optionalFWS <* char ')'--cfws :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-cfws =-  ((foldMany1 (optionalFWS <<>> comment) *> optionalFWS) $> singleton ' ')-  <|> fws---- | CFWS collapsed to a single SPACE character, or empty string----optionalCFWS :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-optionalCFWS = cfws <|> pure mempty--atom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-atom = optionalCFWS *> foldMany1 (singleton . toChar <$> atext) <* optionalCFWS--word :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-word = atom <|> quotedString--dotAtomText :: (Alternative (f s), CharParsing f s a) => (f s) (NonEmpty s)-dotAtomText = fromList <$> (takeWhile1 isAtext `A.sepBy1` char '.')--dotAtom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) (NonEmpty s)-dotAtom = optionalCFWS *> dotAtomText <* optionalCFWS--localPart :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-localPart = (fold . intersperse (singleton '.') <$> dotAtom) <|> quotedString---- | Printable US-ASCII excl "[", "]", or "\"-isDtext :: Char -> Bool-isDtext c = (c >= chr 33 && c <= chr 90) || (c >= chr 94 && c <= chr 126)--dText :: CharParsing f s a => (f s) a-dText = satisfy isDtext--domainLiteral :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-domainLiteral =-  optionalCFWS *> char '['-  *> foldMany (optionalFWS <<>> (singleton . toChar <$> dText) <<>> optionalFWS)-  <* char ']' <* optionalFWS----- | Modify a parser to produce a case-insensitive value----ci :: FoldCase s => A.Parser s -> A.Parser (CI s)-ci = fmap mk----- | Combine two semigroup parsers into one-(<<>>) :: (Semigroup m, Applicative f) => f m -> f m -> f m-(<<>>) = liftA2 (<>)---- | Parse zero or more values and fold them-foldMany :: (Monoid m, Alternative f) => f m -> f m-foldMany = fmap fold . many---- | Parse one or more values and fold them-foldMany1 :: (Semigroup m, Alternative f) => f m -> f m-foldMany1 = fmap (fold1 . fromList) . A.many1---- | Parse one or more values and fold them with a separating element-foldMany1Sep :: (Semigroup m, Alternative f) => m -> f m -> f m-foldMany1Sep sep = fmap (fold1 . intersperse sep . fromList) . A.many1---- | Skip until the given parser succeeds------ @@--- λ> parseOnly (string "foo" *> skipTill (string ".") *> endOfInput) "foobar."--- Right ()--- @@----skipTill :: A.Parser a -> A.Parser ()-skipTill = void . spanTill---- | Current offset in the input-position :: AT.Parser i Int-position = AT.Parser $ \t pos more _lose suc -> suc t pos more (AT.fromPos pos)---- | Number of elements between current position and first position--- at which parser matches (fails if it never matches).  Also--- consumes the input on which the parser succeeds.------ @@--- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar."--- Right 3--- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar"--- Left "not enough input"--- @@----spanTill :: A.Parser a -> A.Parser Int-spanTill p = liftA2 (flip (-)) position q-  where-  q = position <* p <|> A.anyWord8 *> q---- | Run the parser from the specified offset.------ Should only be used to seek backwards, otherwise--- you could seek beyond the buffer.  User beware.------ @@--- λ> parseOnly (seek 3 *> takeByteString) "foobar"--- Right "bar"--- @@----seek :: Int -> A.Parser ()-seek pos = AT.Parser $ \t _pos more _lose win -> win t (AT.Pos pos) more ()---- | Take until the parser matches (fails if it never matches).------ @@--- λ> parseOnly (takeTill' (string "bar") <* endOfInput) "foobar"--- Right "foo"--- @@----takeTill' :: A.Parser a -> A.Parser B.ByteString-takeTill' p = do-  pos <- position-  off <- spanTill p-  newPos <- position-  seek pos *> A.take off <* seek newPos---- | Number of elements between current position and first position--- at which the pattern matches (fails if it never matches).  Also--- consumes the pattern.------ Uses Boyer-Moore algorithm to efficiently search the input.------ @@--- λ> parseOnly (string "foo" *> spanTillString ".") "foobar."--- Right 3--- λ> parseOnly (string "foo" *> spanTillString ".") "foobar"--- Left "not enough input"--- @@----spanTillString :: B.ByteString -> A.Parser Int-spanTillString pat-  | B.null pat = position-  | otherwise = position >>= go-  where-  search = indices pat-  go start = do-    pos <- position-    buf <- takeBuffer-    case search buf of-      (offset:_) ->-        -- Pattern was found.  Seek to end of pattern and return the span-        seek (pos + offset + B.length pat) $> pos + offset - start-      _ ->-        -- We hit the end of the buffer without a match.  Seek to-        -- (length buf - length pat), demand more input and go again.-        seek (max start (B.length buf - B.length pat)) *> A.demandInput *> go start---- | Efficient skip, using Boyer-Moore to locate the pattern.------ @@--- λ> parseOnly (string "foo" *> skipTillString "." *> endOfInput) "foobar."--- Right ()--- @@+-- This file is part of purebred-email+-- Copyright (C) 2021  Fraser Tweedale ---skipTillString :: B.ByteString -> A.Parser ()-skipTillString = void . spanTillString---- | Efficient take, using Boyer-Moore to locate the pattern.+-- 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. ----- @@--- λ> parseOnly (takeTillString "bar" <* endOfInput) "foobar"--- Right "foo"--- @@+-- 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. ---takeTillString :: B.ByteString -> A.Parser B.ByteString-takeTillString pat = do-  pos <- position-  off <- spanTillString pat-  newPos <- position-  seek pos *> A.take off <* seek newPos+-- 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/>. --- | /O(1)/ Take the rest of the buffer, but do not demand--- any more input.----takeBuffer :: A.Parser B.ByteString-takeBuffer = do-  start <- position-  end <- bufSize-  A.take (end - start)+module Data.RFC5322.Internal+  {-# DEPRECATED "Use \"Data.IMF.Syntax\" instead" #-}+  ( module X ) where -bufSize :: forall t. AT.Chunk t => AT.Parser t Int-bufSize = AT.Parser $-  \t pos more _lose win ->-    win t pos more-      (AT.fromPos $ AT.atBufferEnd (undefined :: t) t)+import Data.IMF.Syntax as X

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

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

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2018-2021  Róman Joost and Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} @@ -11,9 +27,7 @@ import Test.Tasty.Golden (goldenVsStringDiff) import Control.Lens (over, (&), set, at) import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Lazy as LB-import Data.Time.Clock (UTCTime(..), secondsToDiffTime)-import Data.Time.Calendar (Day(..))+import Data.Time (Day(..), UTCTime(..), secondsToDiffTime, utc, utcToZonedTime)  import qualified Data.CaseInsensitive as CI @@ -76,9 +90,11 @@                 contentTypeApplicationOctetStream                 (Just "foo.bin")                 "fileContentsASDF"-        now = UTCTime (ModifiedJulianDay 123) (secondsToDiffTime 123)-    in createMultipartMixedMessage "asdf" (fromList [p, a])+        nowUTC = UTCTime (ModifiedJulianDay 123) (secondsToDiffTime 123)+        now = utcToZonedTime utc nowUTC+        Right boundary = makeBoundary "asdf"+    in createMultipartMixedMessage boundary (fromList [p, a])        & set (headers . at "From") (Just $ renderMailboxes [from'])        . set (headers . at "To") (Just $ renderAddresses [to'])-       . set (headers . at "Date") (Just $ renderRFC5422Date now)+       . set (headers . at "Date") (Just $ renderRFC5322Date now)        . set (headers . at "Subject") (Just $ T.encodeUtf8 subject)

@@ -1,3 +1,19 @@+-- This file is part of purebred-email+-- Copyright (C) 2018-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/>.+ {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE OverloadedStrings #-} module Headers where@@ -22,7 +38,7 @@ import Test.QuickCheck.Instances ()  import Data.MIME-import qualified Data.RFC5322.Address.Text as AddressText+import qualified Data.IMF.Text as AddressText   (mailbox, address, renderAddress)  renderField :: (CI.CI B.ByteString, B.ByteString) -> L.ByteString@@ -40,7 +56,7 @@   , ixAndAt   , contentTypeTests   , parameterTests-  , testReferencesField+  , testReply   , testFromToCcBccOptics   , testProperty "field rendering round-trip" prop_renderHeadersRoundtrip   , testProperty "folded fields no longer than 78 chars" prop_foldedUnstructuredLimited@@ -49,17 +65,14 @@ testFromToCcBccOptics :: TestTree testFromToCcBccOptics = testGroup "headerFrom/To/Cc/Bcc tests" $   let-    alice = Mailbox Nothing (AddrSpec "alice" (DomainDotAtom ("example" :| ["com"])))-    bob = Mailbox Nothing (AddrSpec "bob" (DomainDotAtom ("example" :| ["com"])))-    carol = Mailbox Nothing (AddrSpec "carol" (DomainDotAtom ("example" :| ["com"])))     msg = createTextPlainMessage "hi"-    fromAlice = set (headerFrom defaultCharsets) [alice] msg+    fromAlice = set (headerFrom defaultCharsets) [Single alice] msg     fromAliceToBob = set (headerTo defaultCharsets) [Single bob] fromAlice     fromAliceToCarolAndBob = over (headerTo defaultCharsets) (Single carol :) fromAliceToBob   in     [ testCase "From empty" $ view (headerFrom defaultCharsets) msg @?= []     , testCase "To empty" $ view (headerTo defaultCharsets) msg @?= []-    , testCase "set From alice" $ view (headerFrom defaultCharsets) fromAlice @?= [alice]+    , testCase "set From alice" $ view (headerFrom defaultCharsets) fromAlice @?= [Single alice]     , testCase "set To bob" $ view (headerTo defaultCharsets) fromAliceToBob @?= [Single bob]     , testCase "add To carol" $ view (headerTo defaultCharsets) fromAliceToCarolAndBob @?= [Single carol, Single bob]     , testCase "removing header" $ has (header "From") (set (headerFrom defaultCharsets) [] fromAlice) @?= False@@ -99,8 +112,8 @@ rendersAddressesToTextSuccessfully :: TestTree rendersAddressesToTextSuccessfully =   testGroup "renders addresses to text" $-  (\(desc, address, expected) ->-     testCase desc $ expected @=? AddressText.renderAddress address) <$>+  (\(desc, addr, expected) ->+     testCase desc $ expected @=? AddressText.renderAddress addr) <$>   xs   where     xs =@@ -285,43 +298,124 @@       @?= Headers [("Content-Disposition", "attachment; foo=bar")]   ] --- RFC5322 - 3.6.4. Identification Fields-testReferencesField :: TestTree-testReferencesField =-  testGroup "references field in reply" $-  (\(desc, hdrs, expected) ->-     testCase desc $ expected @=? view replyHeaderReferences hdrs) <$>-  fixtures+-- Test the 'reply' function+testReply :: TestTree+testReply =+  testGroup "test 'reply' function" $+    [ testCase "Message-ID -> In-Reply-To" $+        view headerInReplyTo rep1 @?= [msg1ID]+    , testCase "Message-Id -> References" $+        view headerReferences rep1 @?= [msg1ID]+    , testCase "References + Message-Id -> References" $+        view headerReferences rep2 @?= [msg1ID, rep1ID]+    , testCase "In-Reply-To (no References) + Message-Id -> References" $+        view headerReferences rep_noRef_IRT @?= [msg1ID, rep1ID]+    , testCase "multi In-Reply-To (no Ref) + Message-Id -> Ref = [msgid]" $+        view headerReferences rep_noRef_2IRT @?= [rep1ID]++    , testCase "prepends 'Re: ' to Subject" $+        view (headerSubject defaultCharsets) rep1+          @?= Just "Re: Hello, world!"+    , testCase "doesn't prepend 'Re: ' if already a prefix" $+        view (headerSubject defaultCharsets) rep2+          @?= Just "Re: Hello, world!"++    , testCase "GroupReply (remove self)" $ do+        view (headerFrom defaultCharsets) msg1+          @=? view (headerTo defaultCharsets) rep1+        view (headerTo defaultCharsets) rep1+          @?= [Single alice]+        view (headerCC defaultCharsets) rep1+          @?= [Single carol, Single frank]++    , testCase "GroupReply (ignore self)" $ do+        view (headerFrom defaultCharsets) msg1+          @=? view (headerTo defaultCharsets) rep1'+        view (headerTo defaultCharsets) rep1'+          @?= [Single alice]+        view (headerCC defaultCharsets) rep1'+          @?= [Single bob, Single carol, Single frank]++    , testCase "SingleReply" $ do+        view (headerFrom defaultCharsets) rep1+          @=? view (headerTo defaultCharsets) rep2+        view (headerCC defaultCharsets) rep2 @=? []++    , testCase "ReplyFromMatchingMailbox, ReplyFromRewriteOn" $ do+        view (headerFrom defaultCharsets) rep2+          @?= [Single carolWithDisplayName]++    , testCase "ReplyFromMatchingMailbox, ReplyFromRewriteOff" $ do+        view (headerFrom defaultCharsets) rep2'+          @?= [Single carol]++    , testCase "ReplyFromPreferredMailbox" $ do+        view (headerFrom defaultCharsets) rep2''+          @?= [Single "carol@unknown.example.org"]++    , testCase "Reply-To -> To" $+        view (headerTo defaultCharsets) rep_ReplyTo @?= [Single frank]+    ]   where-    fixtures =-      [ ("no ident fields", empty, Nothing)-      , ( "messageid only"-        , empty & set (at "message-id") (Just "asdf")-        , Just "asdf")-      , ( "references only"-        , empty & set (at "references") (Just "references")-        , Just "references")-      , ( "references & message id"-        , empty &-          set (at "references") (Just "references") .-          set (at "message-id") (Just "messageid")-        , Just "references messageid")-      , ( "in-reply-to and no references"-        , empty & set (at "in-reply-to") (Just "replyto")-        , Just "replyto")-      , ( "in-reply-to and message-id"-        , empty &-          set (at "in-reply-to") (Just "replyto") .-          set (at "message-id") (Just "message-id")-        , Just "replyto message-id")-      , ( "in-reply-to and references"-        , empty &-          set (at "in-reply-to") (Just "replyto") .-          set (at "references") (Just "references") .-          set (at "message-id") (Just "messageid")-        , Just "references messageid")-      ]+    mkSettings = ReplySettings+      ReplyToSender+      ReplyFromMatchingMailbox+      ReplyFromRewriteOn+      SelfInRecipientsRemove+    bobSettings   = mkSettings (pure bob) & set replyMode ReplyToGroup+    carolSettings =+      mkSettings ("carol@unknown.example.org" :| [carolWithDisplayName]) +    extraMsgId = (\(Right a) -> a) $ parseOnly parseMessageID "<extra@host>"++    msg1ID = (\(Right a) -> a) $ parseOnly parseMessageID "<msg1@host>"+    msg1 = createTextPlainMessage "hello, world!"+      & set headerMessageID (Just msg1ID)+      . set (headerSubject defaultCharsets) (Just "Hello, world!")+      . set (headerFrom defaultCharsets) [Single alice]+      . set (headerTo defaultCharsets) [Single bob, Single carol]+      . set (headerCC defaultCharsets) [Single frank]++    rep1ID = (\(Right a) -> a) $ parseOnly parseMessageID "<rep1@host>"+    rep1 = reply defaultCharsets bobSettings msg1+      & set headerMessageID (Just rep1ID)+    rep1' =  -- same as rep1, but with SelfInRecipientsIgnore+      let bobSettings' =+            bobSettings & set selfInRecipientsMode SelfInRecipientsIgnore+      in reply defaultCharsets bobSettings' msg1+          & set headerMessageID (Just rep1ID)++    rep2ID = (\(Right a) -> a) $ parseOnly parseMessageID "<rep2@host>"+    rep2 = reply defaultCharsets carolSettings rep1+      & set headerMessageID (Just rep2ID)+    rep2' =  -- same as rep2, but with ReplyFromRewriteOff+      let carolSettings' =+            carolSettings & set replyFromRewriteMode ReplyFromRewriteOff+      in reply defaultCharsets carolSettings' rep1+          & set headerMessageID (Just rep2ID)+    rep2'' = -- same as rep2, but with ReplyFromPreferredMailbox+      let carolSettings' =+            carolSettings & set replyFromMode ReplyFromPreferredMailbox+      in reply defaultCharsets carolSettings' rep1+          & set headerMessageID (Just rep2ID)++    -- reply to a message with no References + single-valued In-Reply_To+    rep_noRef_IRT =+      reply defaultCharsets carolSettings (set headerReferences [] rep1)++    -- reply to a message with no References + multi-valued In-Reply_To+    rep_noRef_2IRT =+      reply defaultCharsets carolSettings $+        rep1+          & set headerReferences []+          & over headerInReplyTo (extraMsgId:)++    -- reply to a message with Reply-To header set+    rep_ReplyTo =+      reply defaultCharsets carolSettings+        (set (headerReplyTo defaultCharsets) [Single frank] msg1)++ -- | Generate headers genFieldItem :: Gen B.ByteString genFieldItem = resize 55 (B.pack <$> listOf1 (suchThat arbitrary isFtext))@@ -362,3 +456,10 @@         ""      -> [acc <> h]         "\r\n"  -> acc <> h : go "" (L.drop 2 t)         _       -> go (acc <> h <> L.take 1 t) (L.drop 1 t)++alice, bob, carol, carolWithDisplayName, frank :: Mailbox+alice = "alice@example.com"+bob = "bob@example.com"+carol = "carol@example.com"+carolWithDisplayName = "Carol Charlie <carol@example.com>"+frank = "frank@example.com"

@@ -26,11 +26,11 @@ import Data.Either (isLeft) import Data.List.NonEmpty (fromList) import Data.String (fromString)-import Data.Time.Clock (UTCTime)  import Control.Lens import qualified Data.ByteString as B import qualified Data.Text as T+import Data.Time (ZonedTime(ZonedTime), timeZoneMinutes)  import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertFailure, testCase)@@ -136,14 +136,14 @@         set           (attachments . headers . contentDisposition . traversed . filenameParameter)           Nothing-        (Message (Headers []) (Multipart . fromList $+        (Message (Headers []) (Multipart Mixed boundary . fromList $           [ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment; filename=bar.pdf")]) (Part "")           ]         ))         @?=-        Message (Headers []) (Multipart . fromList $+        Message (Headers []) (Multipart Mixed boundary . fromList $           [ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment")]) (Part "")@@ -153,6 +153,7 @@   where     lFilename = headers . contentDisposition . traversed . filename defaultCharsets     stripPath = snd . T.breakOnEnd "/"+    Right boundary = makeBoundary "boundary"  testParse :: TestTree testParse = testGroup "parsing tests"@@ -200,6 +201,10 @@       testHeaderDateGet       "Thu, 4 May 2017 03:08:43 +0000"       (Just $ read "2017-05-04 03:08:43 UTC")+  , testCase "headerDate get valid date with comment" $+      testHeaderDateGet+      "Fri, 15 Jan 2021 18:17:11 -0500 (EST)"+      (Just $ read "2021-01-15 18:17:11 EST")   , testCase "headerDate get invalid date" $       testHeaderDateGet       "Thu, 4 NOTMAY 2017 03:08:43 +0000"@@ -209,15 +214,17 @@   , testCase "headerDate unset" $ testHeaderDateSet Nothing   ] -testHeaderDateGet :: B.ByteString -> Maybe UTCTime -> Assertion+testHeaderDateGet :: B.ByteString -> Maybe ZonedTime -> Assertion testHeaderDateGet headerStr time =-  view headerDate msg @?= time+  fmap explode (view headerDate msg) @?= fmap explode time   where     Right msg = parse (message mime) msgStr     msgStr = "Date: " <> headerStr <> "\n\nbody\n" :: B.ByteString+    explode (ZonedTime lt z) = (lt, timeZoneMinutes z) -testHeaderDateSet :: Maybe UTCTime -> Assertion+testHeaderDateSet :: Maybe ZonedTime -> Assertion testHeaderDateSet time =-  view headerDate msg @?= time+  fmap explode (view headerDate msg) @?= fmap explode time   where+    explode (ZonedTime lt z) = (lt, timeZoneMinutes z)     msg = set headerDate time $ createTextPlainMessage "body"

@@ -31,16 +31,19 @@  import Control.Lens (set, view) import qualified Data.ByteString as B+import Data.CaseInsensitive import qualified Data.Text as T+import System.Random (uniform)  import Test.Tasty import Test.Tasty.Hedgehog import Hedgehog import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Internal.Gen as Gen import qualified Hedgehog.Range as Range  import Data.MIME-import Data.RFC5322.Internal (isAtext)+import Data.IMF.Syntax (isAtext)  tests :: TestTree tests = testGroup "message tests"@@ -72,7 +75,7 @@   -- Generate a 50 character multipart boundary.  These MUST be unique   -- for all (nested) multipart messages.  Assume negligible probability   -- of collision.-  genBoundary = Gen.utf8 (Range.singleton 50) printableAsciiChar+  genBoundary = Gen.generate (\_size seed -> fst (uniform seed))    go 0 = genTextPlain   go n = createMultipartMixedMessage@@ -103,14 +106,14 @@  prop_messageFromRoundTrip :: Property prop_messageFromRoundTrip = property $ do-  from <- forAll genMailbox+  from <- Single <$> forAll genMailbox   let     l = headerFrom defaultCharsets     msg = set l [from] (createTextPlainMessage "Hello")   (view l <$> parse (message mime) (renderMessage msg)) === Right [from]  genDomain :: Gen Domain-genDomain = DomainDotAtom <$> genDotAtom -- TODO domain literal+genDomain = DomainDotAtom . fmap mk <$> genDotAtom -- TODO domain literal  genDotAtom :: Gen (NonEmpty B.ByteString) genDotAtom = Gen.nonEmpty (Range.linear 1 5) (Gen.utf8 (Range.linear 1 20) (Gen.filter isAtext Gen.ascii))

@@ -1,5 +1,5 @@ -- This file is part of purebred-email--- Copyright (C) 2019  Fraser Tweedale+-- Copyright (C) 2019, 2021  Fraser Tweedale -- -- purebred-email is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by@@ -21,15 +21,17 @@ import Data.Either (isLeft)  import Data.Attoparsec.ByteString.Lazy as AL-import Data.ByteString as B-import Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as L+import Data.Time (ZonedTime(ZonedTime), timeZoneMinutes) import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Data.RFC5322-import Data.RFC5322.Internal (takeTillString)+import Data.IMF+import Data.IMF.Syntax (takeTillString)  tests :: TestTree tests = testGroup "Parser tests"@@ -43,6 +45,7 @@             AL.Done r' l' -> r' == L.fromStrict r && l' == l             _ -> False   , testBodyParsing+  , testDateTimeParsing   ]  @@ -79,3 +82,100 @@     msg = "From: alice@example.net\r\n"     hdrs = Headers [("From", "alice@example.net")]     opt _ = OptionalBody (Present <$> AL.string "yeah", NotPresent)++testDateTimeParsing :: TestTree+testDateTimeParsing = testGroup "dateTime parsing" $+  let+    now = explode $ read "2021-01-03 20:16:00 +1000"+    go = fmap explode . parseOnly (dateTime <* endOfInput)+    explode (ZonedTime lt z) = (lt, timeZoneMinutes z)+  in+    [ testCase "good (full)" $+        go "Sun, 03 Jan 2021 20:16:00 +1000"+        @?= Right now+    , testCase "good (comment)" $+        go "Sun, 03 Jan 2021 20:16:00 +1000 (wat)"+        @?= Right now+    , testCase "good (extra whitespace)" $+        go "  Sun,  03  Jan  2021  20:16:00  +1000  "+        @?= Right now+    , testCase "good (no seconds)" $+        go "Sun, 03 Jan 2021 20:16 +1000"+        @?= Right now+    , testCase "good (no day-of-week)" $+        go "03 Jan 2021 20:16:00 +1000"+        @?= Right now+    , testCase "good (single-digit date)" $+        go "Sun, 3 Jan 2021 20:16:00 +1000"+        @?= Right now+    , testCase "good (leap second)" $+        go "Sun, 03 Jan 2021 20:16:60 +1000"+        @?= Right (explode $ read "2021-01-03 20:16:60 +1000")+    , testCase "good (5-digit year)" $+        go "Sun, 03 Jan 12021 20:16:00 +1000"+        @?= Right (explode $ read "12021-01-03 20:16:00 +1000")+    , testCase "bad (invalid day-of-week)" $+        isLeft (go "Moo, 03 Jan 2021 20:16:00 +1000")+        @?= True+    , testCase "bad (inconsistent day-of-week)" $+        isLeft (go "Mon, 03 Jan 2021 20:16:00 +1000")+        @?= True+    , testCase "bad (day < 1)" $+        isLeft (go "Thu, 01 Jan 2021 20:16:00 +1000")+        @?= True+    , testCase "bad (out of range day)" $+        isLeft (go "Tue, 33 Jan 2021 20:16:00 +1000")+        @?= True+    , testCase "bad (inconsistent day of month)" $+        isLeft (go "Mon, 29 Feb 2021 20:16:00 +1000")+        @?= True+    , testCase "bad (invalid month)" $+        isLeft (go "Sun, 03 Joo 2021 20:16:00 +1000")+        @?= True+    , testCase "bad (year insufficient digits)" $+        isLeft (go "03 Jan 9 20:16:00 +1000")+        @?= True+    , testCase "bad (year < 1900)" $+        isLeft (go "Sun, 03 Jan 1899 20:16:00 +1000")+        @?= True+    , testCase "bad (hour > 23)" $+        isLeft (go "Sun, 03 Jan 2021 24:16:00 +1000")+        @?= True+    , testCase "bad (minute > 59)" $+        isLeft (go "Sun, 03 Jan 2021 20:60:00 +1000")+        @?= True+    , testCase "bad (second > 60)" $+        isLeft (go "Sun, 03 Jan 2021 20:16:61 +1000")+        @?= True+    , testCase "bad (no timezone)" $+        isLeft (go "Sun, 03 Jan 2021 20:16:00")+        @?= True+    , testCase "bad (invalid tz seconds)" $+        isLeft (go "Sun, 03 Jan 2021 20:16:00 +0960")+        @?= True+    , testCase "good (obs-zone grammar)" $+        (fmap (fmap snd) . traverse go . fmap ("Sun, 03 Jan 2021 20:16:00 " <>))+          (+            ["UT", "GMT", "EST", "EDT", "CST", "CDT", "MST", "MDT", "PST", "PDT"]+            <> fmap Char8.singleton (['A'..'I'] <> ['K'..'Z'] <> ['a'..'i'] <> ['k'..'z'])+          )+        @?= Right (+          let mil = [1..12] <> fmap negate [1..12] <> [0]+          in fmap (* 60) ([0, 0, -5, -4, -6, -5, -7, -6, -8, -7] <> mil <> mil)+        )+    , testCase "bad (obs-zone grammar)" $+        all (isLeft . go) (("Sun, 03 Jan 2021 20:16:00 " <>) <$> ["UTC", "CET", "AEST", "J"])+        @?= True+    , testCase "good (obs-year 2 digit)" $+        go "Sun, 03 Jan 21 20:16:00 +1000"+        @?= Right now+    , testCase "good (obs-year 3 digit)" $+        go "Sun, 03 Jan 121 20:16:00 +1000"+        @?= Right now+    , testCase "good (obs-year 2 digit 2049)" $+        go "Sun, 03 Jan 49 20:16:60 +1000"+        @?= Right (explode $ read "2049-01-03 20:16:60 +1000")+    , testCase "good (obs-year 2 digit 1950)" $+        go "Tue, 03 Jan 50 20:16:60 +1000"+        @?= Right (explode $ read "1950-01-03 20:16:60 +1000")+    ]

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