packages feed

email-header (empty) → 0.2.0

raw patch · 15 files changed

+1618/−0 lines, 15 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, base64-bytestring, bytestring, case-insensitive, containers, email-header, tasty, tasty-quickcheck, text, text-icu, time

Files

+ .gitignore view
@@ -0,0 +1,2 @@+cabal-dev/+dist/
+ .travis.yml view
@@ -0,0 +1,3 @@+language: haskell+before_install:+  - sudo apt-get install -qq libicu-dev
+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ email-header.cabal view
@@ -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 <kylerafto@gmail.com>+maintainer:          Kyle Raftogianis <kylerafto@gmail.com>+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
+ src/Network/Email/Charset.hs view
@@ -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
+ src/Network/Email/Header/Doc.hs view
@@ -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
+ src/Network/Email/Header/Layout.hs view
@@ -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
+ src/Network/Email/Header/Parser.hs view
@@ -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
+ src/Network/Email/Header/Pretty.hs view
@@ -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
+ src/Network/Email/Header/Read.hs view
@@ -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
+ src/Network/Email/Header/Render.hs view
@@ -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
+ src/Network/Email/Header/Types.hs view
@@ -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
+ tests/Tests.hs view
@@ -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