Replace test-framework with tasty.
Add a doctest suite.
Bump to v0.0.4.
cabal-version: >= 1.8
author: Michael Orlitzky
maintainer: Michael Orlitzky <michael@orlitzky.com>
cabal-version: >= 1.8
author: Michael Orlitzky
maintainer: Michael Orlitzky <michael@orlitzky.com>
cmdargs == 0.10.*,
directory == 1.2.*,
dns == 1.*,
cmdargs == 0.10.*,
directory == 1.2.*,
dns == 1.*,
HUnit == 1.2.*,
parallel-io == 0.3.*,
pcre-light >= 0.4,
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.*
cmdargs == 0.10.*,
directory == 1.2.*,
dns == 1.*,
cmdargs == 0.10.*,
directory == 1.2.*,
dns == 1.*,
HUnit == 1.2.*,
parallel-io == 0.3.*,
pcre-light >= 0.4,
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:
-- It's not entirely clear to me why I have to reproduce all of this.
ghc-options:
+
+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
source-repository head
type: git
location: http://michael.orlitzky.com/git/email-validator.git
+module EmailAddress (
+ Address,
+ parts,
+ validate_syntax,
+ -- * Test exports
+ email_address_tests )
where
import qualified Data.ByteString.Char8 as BS (
where
import qualified Data.ByteString.Char8 as BS (
- 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,
import Text.Regex.PCRE.Light (
anchored,
caseless,
compile,
dollar_endonly,
match,
type Address = BS.ByteString
type LocalPart = BS.ByteString
type Address = BS.ByteString
type LocalPart = BS.ByteString
-- | Split an address into local/domain parts.
-- | 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)
parts :: Address -> (LocalPart, DomainPart)
parts address =
(before, after)
-- | Check that the lengths of the local/domain parts are within spec.
-- | 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_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.
-- | 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
validate_regex :: Address -> Bool
validate_regex address =
case matches of
-- | 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 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) &&
validate_syntax :: Bool -> Address -> Bool
validate_syntax rfc5322 address =
(validate_length address) &&
else validate_regex address
else validate_regex address
good_addresses :: [Address]
good_addresses =
map BS.pack [
good_addresses :: [Address]
good_addresses =
map BS.pack [
"bad%char@domain.com",
"bad^char@domain.com" ]
"bad%char@domain.com",
"bad^char@domain.com" ]
-test_good_addresses :: Test
+test_good_addresses :: TestTree
- 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
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 =
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
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
- 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
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
test_bad_addresses_rfc =
testCase desc $
assertEqual desc expected actual
expected = True
actual = all (not . (validate_syntax True)) bad_addresses
expected = True
actual = all (not . (validate_syntax True)) bad_addresses
-test_unsupported_addresses :: Test
+test_unsupported_addresses :: TestTree
test_unsupported_addresses =
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
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 =
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
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,
email_address_tests =
testGroup "EmailAddress Tests" [
test_good_addresses,
--- /dev/null
+module Main where
+
+import Test.DocTest ( doctest )
+
+main :: IO ()
+main = doctest [ "-isrc",
+ "-idist/build/autogen",
+ "src/Main.hs" ]
-{-# 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 = do
- let empty_runner_opts = mempty :: RunnerOptions
- defaultMainWithOpts tests empty_runner_opts
+main = defaultMain tests