From 34f7ff7e07e3f3a0e53225b1efeeb6275c67c674 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 15 Feb 2014 14:34:27 -0500 Subject: [PATCH] Bump the email-validate dependency. Replace test-framework with tasty. Add a doctest suite. Bump to v0.0.4. --- email-validator.cabal | 45 ++++++++++++++++++++---- src/EmailAddress.hs | 81 +++++++++++++++++++++++++++++-------------- test/Doctests.hs | 8 +++++ test/TestSuite.hs | 18 +++------- 4 files changed, 106 insertions(+), 46 deletions(-) create mode 100644 test/Doctests.hs diff --git a/email-validator.cabal b/email-validator.cabal index 20c4ff5..5f5192c 100644 --- a/email-validator.cabal +++ b/email-validator.cabal @@ -1,5 +1,5 @@ name: email-validator -version: 0.0.3 +version: 0.0.4 cabal-version: >= 1.8 author: Michael Orlitzky maintainer: Michael Orlitzky @@ -53,12 +53,12 @@ executable email-validator cmdargs == 0.10.*, directory == 1.2.*, dns == 1.*, - email-validate == 1.*, + email-validate == 2.*, HUnit == 1.2.*, parallel-io == 0.3.*, pcre-light >= 0.4, - test-framework == 0.8.*, - test-framework-hunit == 0.3.* + tasty == 0.7.*, + tasty-hunit == 0.4.* main-is: Main.hs @@ -104,12 +104,13 @@ test-suite testsuite cmdargs == 0.10.*, directory == 1.2.*, dns == 1.*, - email-validate == 1.*, + email-validate == 2.*, HUnit == 1.2.*, parallel-io == 0.3.*, pcre-light >= 0.4, - test-framework == 0.8.*, - test-framework-hunit == 0.3.* + tasty == 0.7.*, + tasty-hunit == 0.4.* + -- It's not entirely clear to me why I have to reproduce all of this. ghc-options: @@ -129,6 +130,36 @@ test-suite testsuite -optc-march=native -O2 + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctests.hs + build-depends: + base == 4.*, + -- Additional test dependencies. + doctest == 0.9.* + + -- It's not entirely clear to me why I have to reproduce all of this. + ghc-options: + -Wall + -fwarn-hi-shadowing + -fwarn-missing-signatures + -fwarn-name-shadowing + -fwarn-orphans + -fwarn-type-defaults + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + -rtsopts + -threaded + -optc-O3 + -optc-march=native + -O2 + + + source-repository head type: git location: http://michael.orlitzky.com/git/email-validator.git diff --git a/src/EmailAddress.hs b/src/EmailAddress.hs index 436d3f5..8dca54b 100644 --- a/src/EmailAddress.hs +++ b/src/EmailAddress.hs @@ -1,4 +1,9 @@ -module EmailAddress +module EmailAddress ( + Address, + parts, + validate_syntax, + -- * Test exports + email_address_tests ) where import qualified Data.ByteString.Char8 as BS ( @@ -7,19 +12,18 @@ import qualified Data.ByteString.Char8 as BS ( empty, length, pack, - tail) -import Text.Email.Validate (isValid) -import Test.HUnit (assertEqual) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) + tail ) +import Text.Email.Validate ( isValid ) +import Test.HUnit ( assertEqual ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) import Text.Regex.PCRE.Light ( anchored, caseless, compile, dollar_endonly, match, - utf8 - ) + utf8 ) type Address = BS.ByteString type LocalPart = BS.ByteString @@ -28,6 +32,13 @@ type DomainPart = BS.ByteString -- | Split an address into local/domain parts. +-- +-- Examples: +-- +-- >>> let addr = BS.pack "user@example.com" +-- >>> parts addr +-- ("user","example.com") +-- parts :: Address -> (LocalPart, DomainPart) parts address = (before, after) @@ -41,14 +52,36 @@ parts address = -- | Check that the lengths of the local/domain parts are within spec. +-- +-- Examples: +-- +-- >>> let jr = (replicate 64 'a') ++ "@" ++ (replicate 255 'x') +-- >>> let just_right = BS.pack jr +-- >>> validate_length just_right +-- True +-- >>> let too_long = BS.pack (jr ++ "x") +-- >>> validate_length too_long +-- False +-- validate_length :: Address -> Bool validate_length address = (BS.length localpart <= 64) && (BS.length domain <= 255) where (localpart, domain) = parts address + -- | Validate an email address against a simple regex. This should -- catch common addresses but disallows a lot of (legal) weird stuff. +-- +-- Examples: +-- +-- >>> let addr = BS.pack "user@example.com" +-- >>> validate_regex addr +-- True +-- >>> let bad_addr = BS.pack "user@[]example.com" +-- >>> validate_regex bad_addr +-- False +-- validate_regex :: Address -> Bool validate_regex address = case matches of @@ -64,6 +97,7 @@ validate_regex address = -- | Validate the syntax of an email address by checking its length -- and validating it against either a simple regex or RFC5322, -- depending on the --rfc5322 flag. +-- validate_syntax :: Bool -> Address -> Bool validate_syntax rfc5322 address = (validate_length address) && @@ -72,7 +106,7 @@ validate_syntax rfc5322 address = else validate_regex address --- HUnit tests +-- * Tasty Tests good_addresses :: [Address] good_addresses = map BS.pack [ @@ -120,34 +154,31 @@ unsupported_addresses = "bad%char@domain.com", "bad^char@domain.com" ] -test_good_addresses :: Test +test_good_addresses :: TestTree test_good_addresses = - testCase desc $ - assertEqual desc expected actual + testCase desc $ actual @?= expected where desc = "Good addresses are accepted." expected = True actual = all (validate_syntax False) good_addresses -test_good_addresses_rfc :: Test +test_good_addresses_rfc :: TestTree test_good_addresses_rfc = - testCase desc $ - assertEqual desc expected actual + testCase desc $ actual @?= expected where desc = "Good addresses are accepted with --rfc5322." expected = True actual = all (validate_syntax True) good_addresses -test_bad_addresses :: Test +test_bad_addresses :: TestTree test_bad_addresses = - testCase desc $ - assertEqual desc expected actual + testCase desc $ actual @?= expected where desc = "Bad addresses are not accepted." expected = True actual = all (not . (validate_syntax False)) bad_addresses -test_bad_addresses_rfc :: Test +test_bad_addresses_rfc :: TestTree test_bad_addresses_rfc = testCase desc $ assertEqual desc expected actual @@ -156,25 +187,23 @@ test_bad_addresses_rfc = expected = True actual = all (not . (validate_syntax True)) bad_addresses -test_unsupported_addresses :: Test +test_unsupported_addresses :: TestTree test_unsupported_addresses = - testCase desc $ - assertEqual desc expected actual + testCase desc $ actual @?= expected where desc = "Unsupported addresses are not accepted." expected = True actual = all (not . (validate_syntax False)) unsupported_addresses -test_unsupported_addresses_rfc :: Test +test_unsupported_addresses_rfc :: TestTree test_unsupported_addresses_rfc = - testCase desc $ - assertEqual desc expected actual + testCase desc $ actual @?= expected where desc = "Unsupported addresses are accepted with --rfc5322." expected = True actual = all (validate_syntax True) unsupported_addresses -email_address_tests :: Test +email_address_tests :: TestTree email_address_tests = testGroup "EmailAddress Tests" [ test_good_addresses, diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 index 0000000..b296b90 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,8 @@ +module Main where + +import Test.DocTest ( doctest ) + +main :: IO () +main = doctest [ "-isrc", + "-idist/build/autogen", + "src/Main.hs" ] diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 7dd0880..c93bc62 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,17 +1,9 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -import Data.Monoid (mempty) -import Test.Framework ( - Test, - defaultMainWithOpts, - ) -import Test.Framework.Runners.Options +import Test.Tasty ( TestTree, defaultMain, testGroup ) -import EmailAddress (email_address_tests) +import EmailAddress ( email_address_tests ) -tests :: [Test.Framework.Test] -tests = [ email_address_tests ] +tests :: TestTree +tests = testGroup "All Tests" [ email_address_tests ] main :: IO () -main = do - let empty_runner_opts = mempty :: RunnerOptions - defaultMainWithOpts tests empty_runner_opts +main = defaultMain tests -- 2.43.2