diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +cabal-dev/ +dist/ diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,3 @@ +language: haskell +before_install: + - sudo apt-get install -qq libicu-dev diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Kyle Raftogianis + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Kyle Raftogianis nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# email-header + +[![Build Status](https://travis-ci.org/knrafto/email-header.png?branch=master)](https://travis-ci.org/knrafto/email-header) + +A Haskell library for parsing and rendering email and MIME headers. +It is compliant with the syntax and format described in +[RFC 5322](http://tools.ietf.org/html/rfc5322) and +[RFC 2047](http://tools.ietf.org/html/rfc2047). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/email-header.cabal b/email-header.cabal new file mode 100644 --- /dev/null +++ b/email-header.cabal @@ -0,0 +1,67 @@ +name: email-header +version: 0.2.0 +synopsis: Parsing and rendering of email and MIME headers +description: Parsing and rendering of email and MIME headers +license: BSD3 +license-file: LICENSE +author: Kyle Raftogianis +maintainer: Kyle Raftogianis +stability: experimental +homepage: http://github.com/knrafto/email-header +bug-reports: http://github.com/knrafto/email-header/issues +copyright: Copyright (c) 2014 Kyle Raftogianis +category: Network +build-type: Simple +cabal-version: >= 1.8 + +extra-source-files: + .gitignore + .travis.yml + README.md + +source-repository head + type: git + location: git://github.com/knrafto/email-header.git + +library + hs-source-dirs: src + ghc-options: -Wall + + build-depends: + attoparsec >= 0.9 && < 1, + base >= 4.5 && < 5, + base64-bytestring >= 0.1.2 && < 2, + bytestring >= 0.10 && < 0.11, + case-insensitive, + containers >= 0.4 && < 0.6, + text >= 0.11 && < 2, + text-icu >= 0.6.3 && < 1, + time + + exposed-modules: + Network.Email.Charset + Network.Email.Header.Doc + Network.Email.Header.Layout + Network.Email.Header.Parser + Network.Email.Header.Pretty + Network.Email.Header.Read + Network.Email.Header.Render + Network.Email.Header.Types + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: tests + ghc-options: -Wall -threaded + + build-depends: + base, + bytestring, + case-insensitive, + containers, + email-header, + QuickCheck, + tasty, + tasty-quickcheck, + text, + time diff --git a/src/Network/Email/Charset.hs b/src/Network/Email/Charset.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Charset.hs @@ -0,0 +1,70 @@ +-- | Charset conversions. +module Network.Email.Charset + ( -- * Charsets + Charset + , charsetName + -- * Lookup + , charsets + , lookupCharset + , defaultCharset + -- * Conversion + , fromUnicode + , toUnicode + ) where + +import Prelude hiding (lookup) + +import Data.ByteString (ByteString) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text.ICU.Convert as ICU +import System.IO.Unsafe + +-- | A charset. Charset names are compared fuzzily e.g. @UTF-8@ is equivalent +-- to @utf8@. +newtype Charset = Charset String + deriving (Show) + +instance Eq Charset where + a == b = compare a b == EQ + +instance Ord Charset where + compare (Charset a) (Charset b) = ICU.compareNames a b + +-- | The name of a charset. +charsetName :: Charset -> String +charsetName (Charset s) = s + +-- | All canonical charset names and aliases. +charsets :: Set Charset +charsets = Set.fromList . map Charset . filter legalName $ + concatMap ICU.aliases ICU.converterNames + where + legalName = all (`notElem` ",.=?") + +-- | Lookup a charset from a name or alias, or 'Nothing' if no such charset +-- exists. +lookupCharset :: String -> Maybe Charset +lookupCharset name = case Set.lookupLE c charsets of + Just c' | c' == c -> Just c' + _ -> Nothing + where + c = Charset name + +-- | The default charset, UTF-8. +defaultCharset :: Charset +defaultCharset = Charset "UTF-8" + +-- | Unsafely load a converter from a charset. The resulting converter is not +-- thread-safe, and may fail for invalid charsets. +unsafeLoad :: Charset -> ICU.Converter +unsafeLoad c = unsafePerformIO $ ICU.open (charsetName c) (Just True) + +-- | Convert a Unicode string into a codepage string. +fromUnicode :: Charset -> Text -> ByteString +fromUnicode = ICU.fromUnicode . unsafeLoad + +-- | Convert a codepage string into a Unicode string. +toUnicode :: Charset -> ByteString -> Text +toUnicode = ICU.toUnicode . unsafeLoad diff --git a/src/Network/Email/Header/Doc.hs b/src/Network/Email/Header/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Doc.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Header formatting and pretty-printing. +module Network.Email.Header.Doc + ( -- * Rendering options + RenderOptions(..) + , Encoding(..) + , defaultRenderOptions + -- * Rendering + , Doc + , render + -- * Construction + , prim + , group + , builder + , string + , byteString + , text + -- * Spacing + , space + , newline + , line + , linebreak + , softline + , softbreak + , () + -- * Combinators + , sep + , punctuate + ) where + +import qualified Data.ByteString as B +import Data.ByteString.Lazy.Builder (Builder) +import qualified Data.ByteString.Lazy.Builder as B +import qualified Data.ByteString.Lazy as LB +import Data.List (intersperse) +import Data.Monoid +import Data.String +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Encoding as L + +import Network.Email.Charset +import Network.Email.Header.Layout (Layout) +import qualified Network.Email.Header.Layout as F + +infixr 6 + +-- | Rendering options. +data RenderOptions = RenderOptions + { -- | The maximum line width. + lineWidth :: Int + -- | The indent of each line, in spaces. + , indent :: Int + -- | The charset used to encode text outside US-ASCII range. + , charset :: Charset + -- | The header encoding used for encoded words. + , encoding :: Encoding + } deriving (Eq, Show) + +-- | The encoding used for binary characters in an encoded word. +data Encoding + -- | Quoted-printable encoding. Spaces are represented with underscores, + -- and undisplayable characters are represented as hex pairs. + = QP + -- | Base 64 encoding of all characters. + | Base64 + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +-- | Default rendering options, which uses a line width of 80, and indent of 2, +-- and utf-8 quated-printable encoding. +defaultRenderOptions :: RenderOptions +defaultRenderOptions = RenderOptions + { lineWidth = 80 + , indent = 2 + , charset = defaultCharset + , encoding = QP + } + +-- | A formatted email header. +data Doc + = Empty + | Prim Bool (RenderOptions -> Bool -> Layout Builder) + | Cat Doc Doc + | Union Doc Doc + +instance Monoid Doc where + mempty = Empty + mappend = Cat + +instance IsString Doc where + fromString = string + +-- | Render a document with the given options and initial position. +render :: RenderOptions -> Int -> Doc -> Builder +render r i doc = F.layout i (go [doc]) + where + w = lineWidth r + + go [] = mempty + go (d:ds) = case d of + Empty -> go ds + Prim h f -> f r h <> go ds + Cat x y -> go (x:y:ds) + Union x y -> F.nicest w (go (x:ds)) (go (y:ds)) + +-- | Construct a primitive document from a layout function. The function takes +-- two parameters: the rendering options, and a 'Bool' which indicates +-- whether the containing group is laid out horizontally instead of vertically. +prim :: (RenderOptions -> Bool -> Layout Builder) -> Doc +prim = Prim False + +-- | Flatten a layout, removing all line breaks. +flatten :: Doc -> Doc +flatten Empty = Empty +flatten (Prim _ f) = Prim True f +flatten (Cat x y) = Cat (flatten x) (flatten y) +flatten (Union x _) = x + +-- | Specify an alternative layout with all line breaks flattened. +group :: Doc -> Doc +group x = Union (flatten x) x + +-- | Construct a 'Doc' from a 'B.Builder' and a length. +builder :: Int -> Builder -> Doc +builder k s = prim $ \_ _ -> F.span k s + +-- | Construct a 'Doc' from a 'String'. +string :: String -> Doc +string s = builder (length s) (B.string8 s) + +-- | Construct a 'Doc' from a 'B.ByteString'. +byteString :: B.ByteString -> Doc +byteString s = builder (B.length s) (B.byteString s) + +-- | Construct a 'Builder' from a 'L.Text'. +text :: L.Text -> Doc +text = byteString . LB.toStrict . L.encodeUtf8 + +-- | A space layout. +space :: Layout Builder +space = F.span 1 (B.char8 ' ') + +-- | A newline layout. This will emit a @CRLF@ pair, break to a new line, +-- and indent. +newline :: RenderOptions -> Layout Builder +newline r = + F.span 2 (B.byteString "\r\n") <> + F.break 0 <> + mconcat (replicate1 (indent r) space) + where + replicate1 n a = a : replicate (n - 1) a + +-- | A line break. If undone, behaves like a space. +line :: Doc +line = prim $ \r h -> if h then space else newline r + +-- | A line break. If undone, behaves like `mempty`. +linebreak :: Doc +linebreak = prim $ \r h -> if h then mempty else newline r + +-- | A space if the remaining layout fits, and a line break otherwise. +softline :: Doc +softline = group line + +-- | `mempty` if the remaining layout fits, and a line break otherwise. +softbreak :: Doc +softbreak = group linebreak + +-- | Concatenate with a 'softline' in between. +() :: Doc -> Doc -> Doc +a b = a <> softline <> b + +-- | Separate a list with spaces if it fits. Otherwise, separate with lines. +sep :: [Doc] -> Doc +sep = group . mconcat . intersperse line + +-- | @punctuate p xs@ appends @p@ to every element of @xs@ but the last. +punctuate :: Monoid a => a -> [a] -> [a] +punctuate p = go + where + go [] = [] + go [x] = [x] + go (x:xs) = x <> p : go xs diff --git a/src/Network/Email/Header/Layout.hs b/src/Network/Email/Header/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Layout.hs @@ -0,0 +1,50 @@ +-- | A layout that keeps track of line positions. +module Network.Email.Header.Layout + ( Layout + , layout + , span + , break + , position + , nicest + ) where + +import Prelude hiding (span, break) + +import Data.Monoid + +type LayoutStep a = Int -> (Int -> Bool, a) + +-- | An abstract type representing a lazy layout. +newtype Layout a = Layout { runLayout :: LayoutStep a -> LayoutStep a } + +instance Monoid (Layout a) where + mempty = Layout id + mappend a b = Layout $ runLayout a . runLayout b + +-- | Run a layout with an initial position. +layout :: Monoid a => Int -> Layout a -> a +layout p l = snd $ runLayout l (const (const True, mempty)) p + +-- | Layout an element of a given length. +span :: Monoid a => Int -> a -> Layout a +span k s = Layout $ \c p -> + let ~(fits, b) = c (p + k) + in (\w -> p <= w && fits w, s <> b) + +-- | Layout a new line and set the initial position. +break :: Int -> Layout a +break i = Layout $ \c p -> + let ~(_, b) = c i + in (\w -> p <= w, b) + +-- | Use the current line position to produce a layout. +position :: (Int -> Layout a) -> Layout a +position f = Layout $ \c p -> runLayout (f p) c p + +-- | Choose the first layout if the first line fits within the given length, +-- and the second otherwise. +nicest :: Int -> Layout a -> Layout a -> Layout a +nicest w x y = Layout $ \c p -> + let a@(fits, _) = runLayout x c p + b = runLayout y c p + in if fits w then a else b diff --git a/src/Network/Email/Header/Parser.hs b/src/Network/Email/Header/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Parser.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} +-- | Header parsers. Most exported parsers (with the exception of 'fws', +-- 'cfws', and 'unstructured') are for parsing structured header fields. +-- They expect no leading space and will eat an trailing white space. +module Network.Email.Header.Parser + ( -- * Whitespace + fws + , cfws + -- * Combinators + , lexeme + , symbol + , commaSep + -- * Date and time + , dateTime + -- * Addresses + , address + , mailbox + , mailboxList + , recipient + , recipientList + -- * Message IDs + , messageID + , messageIDList + -- * Text + , phrase + , phraseList + , unstructured + -- * MIME + , mimeVersion + , contentType + , contentTransferEncoding + ) where + +import Control.Applicative +import Control.Monad +import Data.Attoparsec (Parser) +import qualified Data.Attoparsec as A +import qualified Data.Attoparsec.Char8 as A8 +import Data.Attoparsec.Combinator +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +import Data.ByteString.Internal (w2c) +import Data.ByteString.Lazy.Builder +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as L (toStrict) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Monoid +import Data.Time +import Data.Time.Calendar.WeekDate +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Data.Text.Lazy as L (Text, fromChunks) +import Data.Word + +import Network.Email.Charset +import Network.Email.Header.Types hiding (mimeType) + +infixl 3 <+> + +-- | Concatenate the results of two parsers. +(<+>) :: (Applicative f, Monoid a) => f a -> f a -> f a +(<+>) = liftA2 mappend + +-- | Repeat and concatenate. +concatMany :: (Alternative f, Monoid a) => f a -> f a +concatMany p = mconcat <$> many p + +-- | Return a 'Just' value, and 'fail' a 'Nothing' value. +parseMaybe :: Monad m => String -> Maybe a -> m a +parseMaybe s = maybe (fail s) return + +-- | Return a 'Right' value, and 'fail' a 'Left' value. +parseEither :: Monad m => Either String a -> m a +parseEither = either fail return + +-- | Run a 'Builder' as a strict 'B.ByteString'. +toByteString :: Builder -> B.ByteString +toByteString = L.toStrict . toLazyByteString + +-- | Skip folding whitespace. +fws :: Parser () +fws = A8.skipSpace + +-- | Parse a comment, including all nested comments. +comment :: Parser B.ByteString +comment = A8.char '(' *> A.scan (0 :: Int, False) f <* A8.char ')' + where + f (!n, True ) _ = Just (n, False) + f (!n, False) w = case w2c w of + '(' -> Just (n + 1, False) + ')' -> if n == 0 then Nothing else Just (n - 1, False) + '\\' -> Just (n, True) + _ -> Just (n, False) + +-- | Skip any comments or folding whitespace. +cfws :: Parser () +cfws = () <$ fws `sepBy` comment + +-- | Parse a value followed by whitespace. +lexeme :: Parser a -> Parser a +lexeme p = p <* cfws + +-- | Parse a character followed by whitespace. +symbol :: Char -> Parser Char +symbol = lexeme . A8.char + +-- | Quickly (and unsafely) convert a digit to the number it represents. +fromDigit :: Integral a => Word8 -> a +fromDigit w = fromIntegral (w - 48) + +-- | Parse a fixed number of digits. +digits :: Integral a => Int -> Parser a +digits 0 = return 0 +digits 1 = fromDigit <$> A.satisfy A8.isDigit_w8 +digits n = do + s <- A.take n + unless (B.all A8.isDigit_w8 s) $ + fail $ "expected " ++ show n ++ " digits" + return $ B.foldl' (\a w -> 10*a + fromDigit w) 0 s + +-- | Parse a number lexeme with a fixed number of digits. +number :: Integral a => Int -> Parser a +number = lexeme . digits + +-- | Parse a hexadecimal pair. +hexPair :: Parser Word8 +hexPair = decode <$> hexDigit <*> hexDigit + where + decode a b = shiftL a 4 .|. b + hexDigit = fromHexDigit <$> A.satisfy isHexDigit + isHexDigit w = w >= 48 && w <= 57 + || w >= 64 && w <= 70 + || w >= 97 && w <= 102 + fromHexDigit w + | w >= 97 = w - 87 + | w >= 64 = w - 55 + | otherwise = w - 48 + +-- | Parse an token lexeme consisting of all printable characters, but +-- disallowing the specified special characters. +tokenWith :: String -> Parser B.ByteString +tokenWith specials = lexeme (A.takeWhile1 isAtom) + where + isAtom w = w <= 126 && w >= 33 && A.notInClass specials w + +-- | Parse an atom, which contains ASCII letters, digits, and the +-- characters @"!#$%&\'*+-/=?^_`{|}~"@. +atom :: Parser B.ByteString +atom = tokenWith "()<>[]:;@\\\",." + +-- | Parse a dot-atom, or an atom which may contain periods. +dotAtom :: Parser B.ByteString +dotAtom = tokenWith "()<>[]:;@\\\"," + +-- | A MIME token, which contains ASCII letters, digits, and the +-- characters @"!#$%\'*+-^_`{|}~."@. +token :: Parser B.ByteString +token = tokenWith "()<>@,;:\\\"/[]?=" + +-- | A case-insensitive MIME token. +tokenCI :: Parser (CI B.ByteString) +tokenCI = CI.mk <$> token + +-- | Parse a quoted-string. +quotedString :: Parser B.ByteString +quotedString = lexeme $ + toByteString <$ A8.char '"' <*> concatMany quotedChar <* A8.char '"' + where + quotedChar = mempty <$ A.string "\r\n" + <|> word8 <$ A8.char '\\' <*> A.anyWord8 + <|> char8 <$> A8.satisfy (/= '"') + +-- | Parse an encoded word, as per RFC 2047. +encodedWord :: Parser T.Text +encodedWord = do + _ <- A.string "=?" + name <- B8.unpack <$> tokenWith "()<>@,;:\"/[]?.=" + _ <- A8.char '?' + method <- decodeMethod + _ <- A8.char '?' + enc <- method + _ <- A.string "?=" + + charset <- parseMaybe "charset not found" $ lookupCharset name + return $ toUnicode charset enc + where + decodeMethod = quoted <$ A.satisfy (`B.elem` "Qq") + <|> base64String <$ A.satisfy (`B.elem` "Bb") + + quoted = toByteString <$> concatMany quotedChar + + quotedChar = char8 ' ' <$ A8.char '_' + <|> word8 <$ A8.char '=' <*> hexPair + <|> char8 <$> A8.satisfy (not . isBreak) + + isBreak c = A8.isSpace c || c == '?' + + base64String = do + s <- A8.takeWhile (/= '?') + parseEither (Base64.decode s) + +-- | Return a quoted string as-is. +scanString :: Char -> Char -> Parser Builder +scanString start end = lexeme $ do + s <- byteString <$ A8.char start <*> A8.scan False f <* A8.char end + return (char8 start <> s <> char8 end) + where + f True _ = Just False + f False c + | c == end = Nothing + | c == '\\' = Just True + | otherwise = Just False + +-- | Parse an email address, stripping out whitespace and comments. +addrSpec :: Parser B.ByteString +addrSpec = toByteString <$> (localPart <+> at <+> domain) + where + at = char8 <$> symbol '@' + dot = char8 <$> symbol '.' + dotSep p = p <+> concatMany (dot <+> p) + + addrAtom = byteString <$> atom + addrQuote = scanString '"' '"' + domainLiteral = scanString '[' ']' + + localPart = dotSep (addrAtom <|> addrQuote) + domain = dotSep addrAtom <|> domainLiteral + +-- | Parse an address specification in angle brackets. +angleAddrSpec :: Parser B.ByteString +angleAddrSpec = symbol '<' *> addrSpec <* symbol '>' + +-- | Parse two or more occurences of @p@, separated by @sep@. +sepBy2 :: Alternative f => f a -> f b -> f [a] +sepBy2 p sep = (:) <$> p <*> many1 (sep *> p) + +-- | Parse a list of elements, with possibly null entries in between +-- separators. At least one entry or separator will be parsed. +optionalSepBy1 :: Alternative f => f a -> f b -> f [a] +optionalSepBy1 p sep = catMaybes <$> sepBy2 (optional p) sep + <|> return <$> p + +-- | Parse a list of elements, separated by commas. +commaSep :: Parser a -> Parser [a] +commaSep p = optionalSepBy1 p (symbol ',') + +-- | Parse a date and time. +-- TODO: non-numeric timezones (such as \"PDT\") are considered equivalent +-- to UTC time. +dateTime :: Parser ZonedTime +dateTime = do + wday <- optional dayOfWeek + zoned <- zonedTime + let (_, _, expected) = + toWeekDate . localDay . zonedTimeToLocalTime $ zoned + case wday of + Just actual | actual /= expected + -> fail "day of week does not match date" + _ -> return zoned + where + dayOfWeek = dayName <* symbol ',' + localTime = LocalTime <$> date <*> timeOfDay + zonedTime = ZonedTime <$> localTime <*> timeZone + + date = do + d <- lexeme A8.decimal + m <- month + y <- year + parseMaybe "invalid date" $ fromGregorianValid y m d + + year = number 4 + <|> (+ 1900) <$> number 3 + <|> adjust <$> number 2 + where + adjust n | n < 50 = 2000 + n + | otherwise = 1900 + n + + timeOfDay = do + h <- number 2 + m <- symbol ':' *> number 2 + s <- option (0 :: Int) (symbol ':' *> number 2) + parseMaybe "invalid time of day" $ + makeTimeOfDayValid h m (fromIntegral s) + + timeZone = minutesToTimeZone <$> timeZoneOffset + <|> return utc + + timeZoneOffset = lexeme . A8.signed $ do + hh <- digits 2 + mm <- digits 2 + if mm >= 60 + then fail "invalid time zone" + else return $ hh * 60 + mm + + listIndex = lexeme . choice . map (\(n, s) -> n <$ A.string s) . zip [1..] + dayName = listIndex [ "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun" ] + month = listIndex [ "Jan", "Feb", "Mar", "Apr", "May", "Jun" + , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" + ] + +-- | Parse an email address in angle brackets. +angleAddr :: Parser Address +angleAddr = Address <$> angleAddrSpec + +-- | Parse an email address. +address :: Parser Address +address = Address <$> addrSpec + +-- | Parse a 'Mailbox'. +mailbox :: Parser Mailbox +mailbox = Mailbox <$> optional phrase <*> angleAddr + <|> Mailbox Nothing <$> address + +-- | Parse a list of @'Mailbox'es@. +mailboxList :: Parser [Mailbox] +mailboxList = commaSep mailbox + +-- | Parse a 'Recipient'. +recipient :: Parser Recipient +recipient = Group <$> phrase <* symbol ':' <*> mailboxList <* symbol ';' + <|> Individual <$> mailbox + +-- | Parse a list of @'Recipient's@. +recipientList :: Parser [Recipient] +recipientList = commaSep recipient + +-- | Parse a message identifier. +messageID :: Parser MessageID +messageID = MessageID <$> angleAddrSpec + +-- | Parse a list of message identifiers. +messageIDList :: Parser [MessageID] +messageIDList = many1 messageID + +-- | Combine a list of text elements (atoms, quoted strings, encoded words, +-- etc.) into a larger phrase. +fromElements :: [T.Text] -> L.Text +fromElements = L.fromChunks . intersperse (T.singleton ' ') + +-- | Parse a phrase. Adjacent encoded words are concatenated. White space +-- is reduced to a single space, except when quoted or part of an encoded +-- word. +phrase :: Parser L.Text +phrase = fromElements <$> many1 element + where + element = T.concat <$> many1 (lexeme encodedWord) + <|> decodeLatin1 <$> quotedString + <|> decodeLatin1 <$> dotAtom + +-- | Parse a comma-separated list of phrases. +phraseList :: Parser [L.Text] +phraseList = commaSep phrase + +-- | Parse unstructured text. Adjacent encoded words are concatenated. +-- White space is reduced to a single space, except when part of an encoded +-- word. +unstructured :: Parser L.Text +unstructured = fromElements <$ fws <*> many element <* A.endOfInput + where + element = T.concat <$> many1 (encodedWord <* fws) + <|> decodeLatin1 <$> word <* fws + + word = A.takeWhile1 (not . A8.isSpace_w8) + +-- | Parse the MIME version (which should be 1.0). +mimeVersion :: Parser (Int, Int) +mimeVersion = (,) <$> number 1 <* symbol '.' <*> number 1 + +-- | Parse the content type. +contentType :: Parser (MimeType, Parameters) +contentType = (,) <$> mimeType <*> parameters + where + mimeType = MimeType <$> tokenCI <* symbol '/' <*> tokenCI + parameters = Map.fromList <$> many (symbol ';' *> parameter) + parameter = (,) <$> tokenCI <* symbol '=' <*> (token <|> quotedString) + +-- | Parse the content transfer encoding. +contentTransferEncoding :: Parser (CI B.ByteString) +contentTransferEncoding = tokenCI diff --git a/src/Network/Email/Header/Pretty.hs b/src/Network/Email/Header/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Pretty.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Formatting and pretty-printing header types. +module Network.Email.Header.Pretty + ( -- * Combinators + commaSep + -- * Date and time + , dateTime + -- * Addresses + , address + , mailbox + , mailboxList + , recipient + , recipientList + -- * Message IDs + , messageID + , messageIDList + -- * Text + , phrase + , phraseList + , unstructured + -- * MIME + , mimeVersion + , contentType + , contentTransferEncoding + ) where + +import Control.Arrow +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +import Data.ByteString.Lazy.Builder (Builder) +import qualified Data.ByteString.Lazy.Builder as B +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Char +import qualified Data.Map as Map +import Data.Monoid +import Data.Time +import Data.Time.Calendar.WeekDate +import qualified Data.Text.Lazy as L +import Data.Word + +import Network.Email.Charset +import Network.Email.Header.Doc +import Network.Email.Header.Layout as F +import Network.Email.Header.Types + +-- | Separate a group with commas. +commaSep :: (a -> Doc) -> [a] -> Doc +commaSep f = sep . punctuate "," . map f + +-- | Surround a 'Doc' with angle brackets. +angle :: Doc -> Doc +angle d = "<" <> d <> ">" + +-- | Render a case-insensitive 'B.ByteString'. +byteStringCI :: CI B.ByteString -> Doc +byteStringCI = byteString . CI.original + +-- | Format a date and time. +dateTime :: ZonedTime -> Doc +dateTime (ZonedTime local zone) = localTime local timeZone zone + where + localTime (LocalTime day tod) = date day timeOfDay tod + + date day = dayNames !! (w - 1) <> "," + pad_ 2 d months !! (m - 1) pad0 4 (fromInteger y) + where + (y, m, d) = toGregorian day + (_, _, w) = toWeekDate day + + timeOfDay (TimeOfDay h m s) = + pad0 2 h <> ":" <> pad0 2 m <> ":" <> pad0 2 (floor s) + + timeZone = signed timeZoneOffset . timeZoneMinutes + + timeZoneOffset n = pad0 2 hh <> pad0 2 mm + where + (hh, mm) = n `divMod` 60 + + pad c w n = string $ replicate (w - length s) c ++ s + where + s = show n + + pad_ = pad ' ' + pad0 = pad '0' + + signed f n + | n >= 0 = "+" <> f n + | otherwise = "-" <> f (negate n) + + dayNames = [ "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun" ] + months = [ "Jan", "Feb", "Mar", "Apr", "May", "Jun" + , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" + ] + +-- | Format an address. +address :: Address -> Doc +address (Address s) = byteString s + +-- | Format an address with angle brackets. +angleAddr :: Address -> Doc +angleAddr = angle . address + +-- | Format a 'Mailbox'. +mailbox :: Mailbox -> Doc +mailbox (Mailbox n a) = case n of + Nothing -> address a + Just name -> phrase name angleAddr a + +-- | Format a list of 'Mailbox'es. +mailboxList :: [Mailbox] -> Doc +mailboxList = commaSep mailbox + +-- | Format a 'Recipient'. +recipient :: Recipient -> Doc +recipient (Individual m) = mailbox m +recipient (Group name ms) = phrase name <> ":" mailboxList ms <> ";" + +-- | Format a list of 'Recipient's. +recipientList :: [Recipient] -> Doc +recipientList = commaSep recipient + +-- | Format a message identifier +messageID :: MessageID -> Doc +messageID (MessageID s) = angle (byteString s) + +-- | Format a list of message identifiers. +messageIDList :: [MessageID] -> Doc +messageIDList = commaSep messageID + +-- | Convert a word to a hexadecimal value. +hex :: Word8 -> Builder +hex w = toHexDigit a <> toHexDigit b + where + (a, b) = w `divMod` 16 + toHexDigit n + | n < 10 = B.word8 (n + 48) + | otherwise = B.word8 (n + 55) + +-- | Encode a word. +encodeWord :: RenderOptions -> L.Text -> (Int, Builder) +encodeWord r = encodeWith (encoding r) . fromUnicode (charset r) . L.toStrict + where + encodeWith QP = encodeQ + encodeWith Base64 = encodeBase64 + + encodeQ = first getSum . + B.foldr (\w a -> encodeWord8 w <> a) mempty + + encodeWord8 w + | w == 32 = (Sum 1, B.char8 '_') + | isIllegal w = (Sum 3, B.char8 '=' <> hex w) + | otherwise = (Sum 1, B.word8 w) + + isIllegal w = w < 33 + || w > 126 + || w `B.elem` "()<>[]:;@\\\",?=_" + + encodeBase64 b = let e = Base64.encode b + in (B.length e, B.byteString e) + +-- | Split nonempty text into a layout that fits the given width and the +-- remainder. +-- TODO: inefficient +splitWord :: RenderOptions -> Int -> L.Text -> (Layout Builder, L.Text) +splitWord r w t = + first (uncurry F.span) . + last . + takeWhile1 (fits . fst) . + map (first (encodeWord r)) . + drop 1 $ + zip (L.inits t) (L.tails t) + where + fits (l, _) = l <= w + + takeWhile1 _ [] = [] + takeWhile1 p (x:xs) = x : takeWhile p xs + +-- | Layout text as an encoded word. +layoutText :: RenderOptions -> Bool -> L.Text -> Layout Builder +layoutText r h t0 + | L.null t0 = mempty + | h = prefix <> uncurry F.span (encodeWord r t0) <> postfix + | otherwise = splitLines t0 + where + name = map toLower . charsetName $ charset r + + method = case encoding r of + QP -> 'Q' + Base64 -> 'B' + + prefix = F.span (5 + length name) $ + B.byteString "=?" <> + B.string8 name <> + B.char8 '?' <> + B.char8 method <> + B.char8 '?' + + postfix = F.span 2 (B.byteString "?=") + + padding = 7 + length name + + splitLines t = F.position $ \p -> + let (l, t') = splitWord r (lineWidth r - padding - p) t + in prefix <> l <> postfix <> + (if L.null t' then mempty else newline r <> splitLines t') + +-- | Encode text as an encoded word. +encodeText :: L.Text -> Doc +encodeText t = prim $ \r h -> layoutText r h t + +-- | Encode text, given a predicate that checks for illegal characters. +renderText :: (Char -> Bool) -> L.Text -> Doc +renderText isIllegalChar t + | mustEncode = encodeText t + | otherwise = sep (map text ws) + where + ws = L.words t + + mustEncode = L.unwords ws /= t + || any ("=?" `L.isPrefixOf`) ws + || L.any isIllegalChar t + +-- | Format a phrase. The text is encoded as is, unless: +-- +-- * The text contains leading or trailing whitespace, or more than one space +-- between words +-- +-- * Any word begins with @=?@ +-- +-- * Any word contains illegal characters +phrase :: L.Text -> Doc +phrase = renderText (\c -> c > '~' || c < '!' || c `elem` "()<>[]:;@\\\",") + +-- | Format a list of phrases. +phraseList :: [L.Text] -> Doc +phraseList = commaSep phrase + +-- | Format unstructured text. The text is encoded as is, unless: +-- +-- * The text contains leading or trailing whitespace, or more than one space +-- between words +-- +-- * Any word begins with @=?@ +-- +-- * Any word contains illegal characters +unstructured :: L.Text -> Doc +unstructured = renderText (\c -> c > '~' || c < '!') + +-- | Format the MIME version. +mimeVersion :: Int -> Int -> Doc +mimeVersion major minor = int major <> "." <> int minor + where + int = string . show + +-- | Format the content type and parameters. +contentType :: MimeType -> Parameters -> Doc +contentType (MimeType t s) params = sep . punctuate ";" $ + renderMimeType : map renderParam (Map.toList params) + where + renderMimeType = byteStringCI t <> "/" <> byteStringCI s + renderParam (k, v) = byteStringCI k <> "=" <> byteString v + +-- | Format the content transfer encoding. +contentTransferEncoding :: CI B.ByteString -> Doc +contentTransferEncoding = byteStringCI diff --git a/src/Network/Email/Header/Read.hs b/src/Network/Email/Header/Read.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Read.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Reading common header fields. +-- This module is intended to be imported qualified: +-- +-- > import qualified Network.Email.Header.Read as H +module Network.Email.Header.Read + ( -- * Parsing + field + , structuredField + -- * Origination date field + , date + -- * Originator fields + , from + , sender + , replyTo + -- * Destination address fields + , to + , cc + , bcc + -- * Identification fields + , messageID + , inReplyTo + , references + -- * Informational fields + , subject + , comments + , keywords + -- * Resent fields + , resentDate + , resentFrom + , resentSender + , resentTo + , resentCc + , resentBcc + , resentMessageID + -- * MIME fields + , mimeVersion + , contentType + , contentTransferEncoding + , contentID + ) where + +import Control.Applicative +import Data.Attoparsec.Combinator +import Data.Attoparsec.Lazy +import qualified Data.ByteString as B +import Data.CaseInsensitive (CI) +import qualified Data.Text.Lazy as L +import Data.Time.LocalTime + +import qualified Network.Email.Header.Parser as P +import Network.Email.Header.Types + +-- | Lookup and parse a header with a parser. +field :: HeaderName -> Parser a -> Headers -> Maybe a +field k p hs = do + body <- lookup k hs + maybeResult $ parse p body + +-- | Lookup and parse a structured header with a parser. This skips initial +-- comments and folding white space, and ensures that the entire body is +-- consumed by the parser. +structuredField :: HeaderName -> Parser a -> Headers -> Maybe a +structuredField k p = field k (P.cfws *> p <* endOfInput) + +-- | Get the value of the @Date:@ field. +date :: Headers -> Maybe ZonedTime +date = structuredField "Date" P.dateTime + +-- | Get the value of the @From:@ field. +from :: Headers -> Maybe [Mailbox] +from = structuredField "From" P.mailboxList + +-- | Get the value of the @Sender:@ field. +sender :: Headers -> Maybe Mailbox +sender = structuredField "Sender" P.mailbox + +-- | Get the value of the @Reply-To:@ field. +replyTo :: Headers -> Maybe [Recipient] +replyTo = structuredField "Reply-To" P.recipientList + +-- | Get the value of the @To:@ field. +to :: Headers -> Maybe [Recipient] +to = structuredField "To" P.recipientList + +-- | Get the value of the @Cc:@ field. +cc :: Headers -> Maybe [Recipient] +cc = structuredField "Cc" P.recipientList + +-- | Get the value of the @Bcc:@ field. +bcc :: Headers -> Maybe (Maybe [Recipient]) +bcc = structuredField "Bcc" (optional P.recipientList) + +-- | Get the value of the @Message-ID:@ field. +messageID :: Headers -> Maybe MessageID +messageID = structuredField "Message-ID" P.messageID + +-- | Get the value of the @In-Reply-To:@ field. +inReplyTo :: Headers -> Maybe [MessageID] +inReplyTo = structuredField "In-Reply-To" (many1 P.messageID) + +-- | Get the value of the @References:@ field. +references :: Headers -> Maybe [MessageID] +references = structuredField "References" (many1 P.messageID) + +-- | Get the value of the @Subject:@ field. +subject :: Headers -> Maybe L.Text +subject = field "Subject" P.unstructured + +-- | Get the value of the @Comments:@ field. +comments :: Headers -> Maybe L.Text +comments = field "Comments" P.unstructured + +-- | Get the value of the @Keywords:@ field. +keywords :: Headers -> Maybe [L.Text] +keywords = structuredField "Keywords" P.phraseList + +-- | Get the value of the @Resent-Date:@ field. +resentDate :: Headers -> Maybe ZonedTime +resentDate = structuredField "Resent-Date" P.dateTime + +-- | Get the value of the @Resent-From:@ field. +resentFrom :: Headers -> Maybe [Mailbox] +resentFrom = structuredField "Resent-From" P.mailboxList + +-- | Get the value of the @Resent-Sender:@ field. +resentSender :: Headers -> Maybe Mailbox +resentSender = structuredField "Resent-Sender" P.mailbox + +-- | Get the value of the @Resent-To:@ field. +resentTo :: Headers -> Maybe [Recipient] +resentTo = structuredField "Resent-To" P.recipientList + +-- | Get the value of the @Resent-Cc:@ field. +resentCc :: Headers -> Maybe [Recipient] +resentCc = structuredField "Resent-Cc" P.recipientList + +-- | Get the value of the @Resent-Bcc:@ field. +resentBcc :: Headers -> Maybe (Maybe [Recipient]) +resentBcc = structuredField "Resent-Bcc" (optional P.recipientList) + +-- | Get the value of the @Resent-Message-ID:@ field. +resentMessageID :: Headers -> Maybe MessageID +resentMessageID = structuredField "Resent-Message-ID" P.messageID + +-- | Get the value of the @MIME-Version:@ field. +mimeVersion :: Headers -> Maybe (Int, Int) +mimeVersion = structuredField "MIME-Version" P.mimeVersion + +-- | Get the value of the @Content-Type:@ field. +contentType :: Headers -> Maybe (MimeType, Parameters) +contentType = structuredField "Content-Type" P.contentType + +-- | Get the value of the @Content-Transfer-Encoding:@ field. +contentTransferEncoding :: Headers -> Maybe (CI B.ByteString) +contentTransferEncoding = + structuredField "Content-Transfer-Encoding" P.contentTransferEncoding + +-- | Get the value of the @Content-ID:@ field. +contentID :: Headers -> Maybe MessageID +contentID = structuredField "Content-ID" P.messageID diff --git a/src/Network/Email/Header/Render.hs b/src/Network/Email/Header/Render.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Render.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Rendering common header fields. +-- This module is intended to be imported qualified: +-- +-- > import qualified Network.Email.Header.Render as R +module Network.Email.Header.Render + ( -- * Rendering options + RenderOptions(..) + , Encoding(..) + , defaultRenderOptions + -- * Rendering + , Doc + , renderHeaders + -- * Origination date field + , date + -- * Originator fields + , from + , sender + , replyTo + -- * Destination address fields + , to + , cc + , bcc + -- * Identification fields + , messageID + , inReplyTo + , references + -- * Informational fields + , subject + , comments + , keywords + -- * Resent fields + , resentDate + , resentFrom + , resentSender + , resentTo + , resentCc + , resentBcc + , resentMessageID + -- * MIME fields + , mimeVersion + , contentType + , contentTransferEncoding + , contentID + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Builder as B +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Monoid +import qualified Data.Text.Lazy as L +import Data.Time.LocalTime + +import Network.Email.Header.Doc +import qualified Network.Email.Header.Pretty as P +import Network.Email.Header.Types + +-- | Render a list of headers. +renderHeaders :: RenderOptions -> [(HeaderName, Doc)] -> Headers +renderHeaders r = map (renderHeader r) + +-- | Render a header. +renderHeader + :: RenderOptions + -> (HeaderName, Doc) + -> (HeaderName, HeaderField) +renderHeader r (k, b) = (k, B.toLazyByteString l) + where + l = render r (B.length (CI.original k) + 2) b + +-- | Build a header field. +buildField :: HeaderName -> (a -> Doc) -> a -> (HeaderName, Doc) +buildField k f a = (k, f a) + +-- | Create a @Date:@ field. +date :: ZonedTime -> (HeaderName, Doc) +date = buildField "Date" P.dateTime + +-- | Create a @From:@ field. +from :: [Mailbox] -> (HeaderName, Doc) +from = buildField "From" P.mailboxList + +-- | Create a @Sender:@ field. +sender :: Mailbox -> (HeaderName, Doc) +sender = buildField "Sender" P.mailbox + +-- | Create a @Reply-To:@ field. +replyTo :: [Recipient] -> (HeaderName, Doc) +replyTo = buildField "Reply-To" P.recipientList + +-- | Create a @To:@ field. +to :: [Recipient] -> (HeaderName, Doc) +to = buildField "To" P.recipientList + +-- | Create a @Cc:@ field. +cc :: [Recipient] -> (HeaderName, Doc) +cc = buildField "Cc" P.recipientList + +-- | Create a @Bcc:@ field. +bcc :: Maybe [Recipient] -> (HeaderName, Doc) +bcc = buildField "Bcc" (maybe mempty P.recipientList) + +-- | Create a @Message-ID:@ field. +messageID :: MessageID -> (HeaderName, Doc) +messageID = buildField "Message-ID" P.messageID + +-- | Create a @In-Reply-To:@ field. +inReplyTo :: [MessageID] -> (HeaderName, Doc) +inReplyTo = buildField "In-Reply-To" (sep . map P.messageID) + +-- | Create a @References:@ field. +references :: [MessageID] -> (HeaderName, Doc) +references = buildField "References" (sep . map P.messageID) + +-- | Create a @Subject:@ field. +subject :: L.Text -> (HeaderName, Doc) +subject = buildField "Subject" P.unstructured + +-- | Create a @Comments:@ field. +comments :: L.Text -> (HeaderName, Doc) +comments = buildField "Comments" P.unstructured + +-- | Create a @Keywords:@ field. +keywords :: [L.Text] -> (HeaderName, Doc) +keywords = buildField "Keywords" P.phraseList + +-- | Create a @Resent-Date:@ field. +resentDate :: ZonedTime -> (HeaderName, Doc) +resentDate = buildField "Resent-Date" P.dateTime + +-- | Create a @Resent-From:@ field. +resentFrom :: [Mailbox] -> (HeaderName, Doc) +resentFrom = buildField "Resent-From" P.mailboxList + +-- | Create a @Resent-Sender:@ field. +resentSender :: Mailbox -> (HeaderName, Doc) +resentSender = buildField "Resent-Sender" P.mailbox + +-- | Create a @Resent-To:@ field. +resentTo :: [Recipient] -> (HeaderName, Doc) +resentTo = buildField "Resent-To" P.recipientList + +-- | Create a @Resent-Cc:@ field. +resentCc :: [Recipient] -> (HeaderName, Doc) +resentCc = buildField "Resent-Cc" P.recipientList + +-- | Create a @Resent-Bcc:@ field. +resentBcc :: Maybe [Recipient] -> (HeaderName, Doc) +resentBcc = buildField "Resent-Bcc" (maybe mempty P.recipientList) + +-- | Create a @Resent-Message-ID:@ field. +resentMessageID :: MessageID -> (HeaderName, Doc) +resentMessageID = buildField "Resent-Message-ID" P.messageID + +-- | Create a @MIME-Version:@ field. +mimeVersion :: Int -> Int -> (HeaderName, Doc) +mimeVersion major minor = ("MIME-Version", P.mimeVersion major minor) + +-- | Create a @Content-Type:@ field. +contentType :: MimeType -> Parameters -> (HeaderName, Doc) +contentType t params = ("Content-Type", P.contentType t params) + +-- | Create a @Content-Transfer-Encoding:@ field. +contentTransferEncoding :: CI B.ByteString -> (HeaderName, Doc) +contentTransferEncoding = + buildField "Content-Transfer-Encoding" P.contentTransferEncoding + +-- | Create a @Content-ID:@ field. +contentID :: MessageID -> (HeaderName, Doc) +contentID = buildField "Content-ID" P.messageID diff --git a/src/Network/Email/Header/Types.hs b/src/Network/Email/Header/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Email/Header/Types.hs @@ -0,0 +1,58 @@ +-- | Email header types. +module Network.Email.Header.Types + ( Headers + , HeaderName + , HeaderField + , Address(..) + , Mailbox(..) + , Recipient(..) + , MessageID(..) + , MimeType(..) + , Parameters + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive (CI) +import Data.Map.Strict (Map) +import qualified Data.Text.Lazy as L + +-- | A set of email headers. +type Headers = [(HeaderName, HeaderField)] + +-- | An email header name. +type HeaderName = CI B.ByteString + +-- | The email header field. +type HeaderField = L.ByteString + +-- | An email address. +newtype Address = Address B.ByteString + deriving (Eq, Ord, Show) + +-- | A 'Mailbox' receives mail. +data Mailbox = Mailbox + { displayName :: Maybe L.Text + , mailboxAddress :: Address + } deriving (Eq, Show) + +-- | A 'Recipient' is used to indicate senders and recipients of messages. +-- It may either be an individual 'Mailbox', or a named group of +-- @'Mailbox'es@. +data Recipient + = Individual Mailbox + | Group L.Text [Mailbox] + deriving (Eq, Show) + +-- | A message identifier, which has a similar format to an email address. +newtype MessageID = MessageID B.ByteString + deriving (Eq, Ord, Show) + +-- | A MIME type. +data MimeType = MimeType + { mimeType :: CI B.ByteString + , mimeSubtype :: CI B.ByteString + } deriving (Eq, Ord, Show) + +-- | MIME content type parameters. +type Parameters = Map (CI B.ByteString) B.ByteString diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main + ( main + ) where + +import Control.Applicative +import qualified Data.ByteString.Char8 as B +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Data.Map as Map +import qualified Data.Text.Lazy as L +import Data.Time.Calendar +import Data.Time.LocalTime +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Network.Email.Charset +import qualified Network.Email.Header.Read as H +import qualified Network.Email.Header.Render as R +import Network.Email.Header.Types + +instance Eq ZonedTime where + ZonedTime t1 z1 == ZonedTime t2 z2 = (t1, z1) == (t2, z2) + +instance Arbitrary ZonedTime where + arbitrary = ZonedTime <$> local <*> zone + where + local = do + h <- choose (0, 23) + m <- choose (0, 59) + s <- fromInteger <$> choose (0, 60) + d <- choose (0, 50000) + return $ LocalTime (ModifiedJulianDay d) (TimeOfDay h m s) + + zone = minutesToTimeZone <$> choose (-12*60, 14*60) + +option :: Gen a -> Gen (Maybe a) +option gen = frequency [(1, pure Nothing), (3, Just <$> gen)] + +char :: Gen Char +char = frequency + [ (9, elements [' ' .. '~']) + , (1, arbitrary) + ] + +text :: Gen L.Text +text = L.pack <$> listOf char + +phrase :: Gen L.Text +phrase = L.pack <$> listOf1 char + +token :: Gen B.ByteString +token = resize 20 $ B.pack <$> listOf1 (elements ttext) -- TODO + where + ttext = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "!#$%&'*+-^_`{|}~" + +tokenCI :: Gen (CI B.ByteString) +tokenCI = CI.mk <$> token + +addrSpec :: Gen B.ByteString +addrSpec = B.concat <$> sequence [token, pure "@", token] -- TODO + +mimeVersion :: Gen (Int, Int) +mimeVersion = (,) <$> digit <*> digit + where + digit = choose (0, 9) + +encoding :: Gen (CI B.ByteString) +encoding = elements + ["base64", "quoted-printable", "8bit", "7bit", "binary", "x-token"] + +contentType :: Gen (MimeType, Parameters) +contentType = (,) <$> arbitrary <*> params + where + params = Map.fromList <$> listOf param + param = (,) <$> tokenCI <*> token + +instance Arbitrary Address where + arbitrary = Address <$> addrSpec + +instance Arbitrary Mailbox where + arbitrary = Mailbox <$> option phrase <*> arbitrary + +instance Arbitrary Recipient where + arbitrary = oneof + [Individual <$> arbitrary, Group <$> phrase <*> listOf1 arbitrary] + +instance Arbitrary MessageID where + arbitrary = MessageID <$> addrSpec + +instance Arbitrary MimeType where + arbitrary = MimeType <$> tokenCI <*> tokenCI + +instance Arbitrary R.RenderOptions where + arbitrary = R.RenderOptions + <$> choose (20, 80) + <*> choose (1, 8) + <*> arbitrary + <*> arbitrary + +instance Arbitrary Charset where + arbitrary = pure defaultCharset -- TODO + +instance Arbitrary R.Encoding where + arbitrary = arbitraryBoundedEnum + +list1 :: Arbitrary a => Gen [a] +list1 = listOf1 arbitrary + +roundTrip + :: (Eq a, Show a) + => String + -> Gen a + -> (a -> (HeaderName, R.Doc)) + -> (Headers -> Maybe a) + -> TestTree +roundTrip name gen renderer parser = testProperty name $ + forAll gen $ \a opts -> + let hs = R.renderHeaders opts [renderer a] + in case parser hs of + Nothing -> False + Just b -> b == a + +parsers :: TestTree +parsers = testGroup "round trip" + [ -- Origination date + roundTrip "Date" arbitrary R.date H.date + -- Originator + , roundTrip "From" list1 R.from H.from + , roundTrip "Sender" arbitrary R.sender H.sender + , roundTrip "Reply-To" list1 R.replyTo H.replyTo + -- Destination address + , roundTrip "To" list1 R.to H.to + , roundTrip "Cc" list1 R.cc H.cc + , roundTrip "Bcc" (option list1) R.bcc H.bcc + -- Identification + , roundTrip "Message-ID" arbitrary R.messageID H.messageID + , roundTrip "In-Reply-To" list1 R.inReplyTo H.inReplyTo + , roundTrip "References" list1 R.references H.references + -- Informational + , roundTrip "Subject" text R.subject H.subject + , roundTrip "Comments" text R.comments H.comments + , roundTrip "Keywords" (listOf1 phrase) R.keywords H.keywords + -- Resent + , roundTrip "Resent-Date" arbitrary R.resentDate H.resentDate + , roundTrip "Resent-From" list1 R.resentFrom H.resentFrom + , roundTrip "Resent-Sender" arbitrary R.resentSender H.resentSender + , roundTrip "Resent-To" list1 R.resentTo H.resentTo + , roundTrip "Resent-Cc" list1 R.resentCc H.resentCc + , roundTrip "Resent-Bcc" (option list1) R.resentBcc H.resentBcc + , roundTrip "Resent-Message-ID" arbitrary + R.resentMessageID H.resentMessageID + -- MIME + , roundTrip "MIME-Version" mimeVersion (uncurry R.mimeVersion) H.mimeVersion + , roundTrip "Content-Type" contentType (uncurry R.contentType) H.contentType + , roundTrip "Content-Transfer-Encoding" encoding + R.contentTransferEncoding H.contentTransferEncoding + , roundTrip "Content-ID" arbitrary R.contentID H.contentID + ] + +main :: IO () +main = defaultMain parsers