diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -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. diff --git a/purebred-email.cabal b/purebred-email.cabal --- a/purebred-email.cabal +++ b/purebred-email.cabal @@ -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 + . + 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 + - message parsing and serialisation + - MIME multipart messages () + - Convenient APIs for replying and forward/bounce + - Content transfer and charset decoding/encoding + - MIME message header extensions for non-ASCII text () + - MIME parameter value and encoded word extensions () + - @Content-Disposition@ header field () + - Address syntax in @From@ and @Sender@ fields () 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 diff --git a/src/Data/IMF.hs b/src/Data/IMF.hs new file mode 100644 --- /dev/null +++ b/src/Data/IMF.hs @@ -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 . + +{-# 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 + and updated by +. + +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) diff --git a/src/Data/IMF.hs-boot b/src/Data/IMF.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/IMF.hs-boot @@ -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 . + +module Data.IMF where + +data Mailbox diff --git a/src/Data/IMF/DateTime.hs b/src/Data/IMF/DateTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/IMF/DateTime.hs @@ -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 . + +{-# 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 diff --git a/src/Data/IMF/Syntax.hs b/src/Data/IMF/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/IMF/Syntax.hs @@ -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 . + +{-# 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) diff --git a/src/Data/IMF/Text.hs b/src/Data/IMF/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/IMF/Text.hs @@ -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 . + +{-# 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) diff --git a/src/Data/IMF/Text.hs-boot b/src/Data/IMF/Text.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/IMF/Text.hs-boot @@ -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 . + +module Data.IMF.Text where + +import {-# SOURCE #-} Data.IMF + +readMailbox :: String -> Either String Mailbox diff --git a/src/Data/MIME.hs b/src/Data/MIME.hs --- a/src/Data/MIME.hs +++ b/src/Data/MIME.hs @@ -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 . + {-# 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 + -- ^ + -- Independent body parts, bundled in a particular order. + | Alternative + -- ^ + -- 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 + -- ^ + -- Collection of messages. Parts should have @Content-Type: message/rfc822@. + | Parallel + -- ^ + -- 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@ -} + -- ^ + -- Aggregate or compound objects. + | Signed B.ByteString {- ^ protocol -} B.ByteString {- ^ micalg -} + -- ^ + -- Signed messages. + | Encrypted B.ByteString {- protocol -} + -- ^ + | Report B.ByteString {- report-type -} + -- ^ . + -- Electronic mail reports. + | Multilingual + -- ^ . + -- 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. +-- | +-- 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@ +-- () +-- [@text/csv@] Default: @utf-8@ +-- () +-- [@text/markdown@] No default; @charset@ parameter is REQUIRED +-- () +-- [@text/enriched@] Default: @us-ascii@ +-- () +-- [@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 . +-- 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" diff --git a/src/Data/MIME/Base64.hs b/src/Data/MIME/Base64.hs --- a/src/Data/MIME/Base64.hs +++ b/src/Data/MIME/Base64.hs @@ -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 . + {-# 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' {- diff --git a/src/Data/MIME/Boundary.hs b/src/Data/MIME/Boundary.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Boundary.hs @@ -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 . + +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 diff --git a/src/Data/MIME/Charset.hs b/src/Data/MIME/Charset.hs --- a/src/Data/MIME/Charset.hs +++ b/src/Data/MIME/Charset.hs @@ -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 . + {-# 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 diff --git a/src/Data/MIME/EncodedWord.hs b/src/Data/MIME/EncodedWord.hs --- a/src/Data/MIME/EncodedWord.hs +++ b/src/Data/MIME/EncodedWord.hs @@ -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 . + {-# 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 diff --git a/src/Data/MIME/Error.hs b/src/Data/MIME/Error.hs --- a/src/Data/MIME/Error.hs +++ b/src/Data/MIME/Error.hs @@ -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 . + {-# LANGUAGE LambdaCase #-} module Data.MIME.Error where diff --git a/src/Data/MIME/Internal.hs b/src/Data/MIME/Internal.hs --- a/src/Data/MIME/Internal.hs +++ b/src/Data/MIME/Internal.hs @@ -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 . + {-# LANGUAGE OverloadedStrings #-} module Data.MIME.Internal diff --git a/src/Data/MIME/Parameter.hs b/src/Data/MIME/Parameter.hs --- a/src/Data/MIME/Parameter.hs +++ b/src/Data/MIME/Parameter.hs @@ -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 . + {-# 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 diff --git a/src/Data/MIME/QuotedPrintable.hs b/src/Data/MIME/QuotedPrintable.hs --- a/src/Data/MIME/QuotedPrintable.hs +++ b/src/Data/MIME/QuotedPrintable.hs @@ -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 . + {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Data/MIME/TransferEncoding.hs b/src/Data/MIME/TransferEncoding.hs --- a/src/Data/MIME/TransferEncoding.hs +++ b/src/Data/MIME/TransferEncoding.hs @@ -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 . + {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Data/MIME/Types.hs b/src/Data/MIME/Types.hs --- a/src/Data/MIME/Types.hs +++ b/src/Data/MIME/Types.hs @@ -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 . + {-# LANGUAGE RankNTypes #-} module Data.MIME.Types diff --git a/src/Data/RFC5322.hs b/src/Data/RFC5322.hs --- a/src/Data/RFC5322.hs +++ b/src/Data/RFC5322.hs @@ -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 . --- | 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 diff --git a/src/Data/RFC5322/Address/Text.hs b/src/Data/RFC5322/Address/Text.hs --- a/src/Data/RFC5322/Address/Text.hs +++ b/src/Data/RFC5322/Address/Text.hs @@ -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 . --} 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 diff --git a/src/Data/RFC5322/Address/Types.hs b/src/Data/RFC5322/Address/Types.hs --- a/src/Data/RFC5322/Address/Types.hs +++ b/src/Data/RFC5322/Address/Types.hs @@ -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 . 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 diff --git a/src/Data/RFC5322/Internal.hs b/src/Data/RFC5322/Internal.hs --- a/src/Data/RFC5322/Internal.hs +++ b/src/Data/RFC5322/Internal.hs @@ -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 . --- | /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 diff --git a/tests/ContentTransferEncodings.hs b/tests/ContentTransferEncodings.hs --- a/tests/ContentTransferEncodings.hs +++ b/tests/ContentTransferEncodings.hs @@ -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 . + {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} diff --git a/tests/EncodedWord.hs b/tests/EncodedWord.hs --- a/tests/EncodedWord.hs +++ b/tests/EncodedWord.hs @@ -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 . -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +module EncodedWord where import Data.MIME.Charset import Data.MIME.EncodedWord diff --git a/tests/Generator.hs b/tests/Generator.hs --- a/tests/Generator.hs +++ b/tests/Generator.hs @@ -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 . + {-# 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) diff --git a/tests/Headers.hs b/tests/Headers.hs --- a/tests/Headers.hs +++ b/tests/Headers.hs @@ -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 . + {-# 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 "" + + msg1ID = (\(Right a) -> a) $ parseOnly parseMessageID "" + 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 = 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 = 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 " +frank = "frank@example.com" diff --git a/tests/MIME.hs b/tests/MIME.hs --- a/tests/MIME.hs +++ b/tests/MIME.hs @@ -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" diff --git a/tests/Message.hs b/tests/Message.hs --- a/tests/Message.hs +++ b/tests/Message.hs @@ -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)) diff --git a/tests/Parser.hs b/tests/Parser.hs --- a/tests/Parser.hs +++ b/tests/Parser.hs @@ -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") + ] diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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 . + import Test.Tasty import ContentTransferEncodings as CTE