Email.hs

--  Copyright (C) 2002-2005,2007 David Roundy
--  Copyright (C) 2009 Reinier Lamers
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

-- | This module contains unit tests of the code in 'Darcs.Email'
--
-- These tests check whether the emails generated by darcs meet a few criteria.
-- We check for line length and non-ASCII characters. We apparently do not have
-- to check for CR-LF newlines because that's handled by sendmail.
module Darcs.Test.Email ( emailParsing, emailHeaderNoLongLines,
                          emailHeaderAsciiChars, emailHeaderLinesStart,
                          emailHeaderNoEmptyLines
                        ) where
import Data.Char ( isPrint )
import qualified Data.ByteString as B ( length, unpack, null, head, filter,
                                        cons, empty, foldr, ByteString )
import qualified Data.ByteString.Char8 as BC ( unpack )
import Test.Framework ( Test )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Printer ( text, renderPS )
import Darcs.Email ( makeEmail, readEmail, formatHeader )

-- | Checks that darcs can read the emails it generates
emailParsing :: Test
emailParsing = testProperty "Checking that email can be parsed" $ \s ->
    unlines ("":s++["", ""]) ==
              BC.unpack (readEmail (renderPS
                    $ makeEmail "reponame" [] (Just (text "contents\n"))
                                 (text $ unlines s) (Just "filename")))

-- | Check that formatHeader never creates lines longer than 78 characters
-- (excluding the carriage return and line feed)
emailHeaderNoLongLines :: Test
emailHeaderNoLongLines =
    testProperty "Checking email header line length" $ \field value ->
      let cleanField = cleanFieldString field
      in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value

-- Check that an email header does not contain non-ASCII characters
-- formatHeader doesn't escape field names, there is no such thing as non-ascii
-- field names afaik
emailHeaderAsciiChars :: Test
emailHeaderAsciiChars =
    testProperty "Checking email for illegal characters" $ \field value ->
      let cleanField = cleanFieldString field
      in not (any (>127) (B.unpack (formatHeader cleanField value)))

-- Check that header the second and later lines of a header start with a space
emailHeaderLinesStart :: Test
emailHeaderLinesStart =
    testProperty "Checking for spaces at start of folded email header lines" $ \field value ->
      let headerLines = bsLines (formatHeader cleanField value)
          cleanField  = cleanFieldString field
      in all (\l -> B.null l || B.head l == 32) (tail headerLines)

-- Checks that there are no lines in email headers with only whitespace
emailHeaderNoEmptyLines :: Test
emailHeaderNoEmptyLines =
    testProperty "Checking that there are no empty lines in email headers" $ \field value ->
      let headerLines = bsLines (formatHeader cleanField value)
          cleanField  = cleanFieldString field
          in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines

bsLines :: B.ByteString -> [B.ByteString]
bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])
  where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)
        splitAtLines c  (thisLine, prevLines) = (B.cons c thisLine, prevLines)
        finalizeFold (lastLine, otherLines) = lastLine : otherLines

cleanFieldString :: String -> String
cleanFieldString = filter (\c -> isPrint c && c < '\x80' && c /= ':')