email-validate-2.1.3/0000755000000000000000000000000012531772133012565 5ustar0000000000000000email-validate-2.1.3/Setup.lhs0000644000000000000000000000011712531772133014374 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain email-validate-2.1.3/LICENSE0000644000000000000000000000271712531772133013601 0ustar0000000000000000Copyright (c) 2009 George Pollard All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. email-validate-2.1.3/email-validate.cabal0000644000000000000000000000273212531772133016433 0ustar0000000000000000name: email-validate version: 2.1.3 license: BSD3 license-file: LICENSE author: George Pollard maintainer: George Pollard homepage: http://porg.es/blog/email-address-validation-simpler-faster-more-correct category: Text synopsis: Validating an email address string against RFC 5322 description: Validating an email address string against RFC 5322 build-type: Simple stability: experimental cabal-version: >= 1.10 source-repository head type: git location: git://github.com/Porges/email-validate-hs.git source-repository this type: git location: git://github.com/Porges/email-validate-hs.git tag: v2.1.3 library build-depends: base >= 4.4 && < 5, attoparsec >= 0.10.0, bytestring >= 0.9, ghc-prim default-language: Haskell2010 default-extensions: DeriveGeneric, DeriveDataTypeable hs-source-dirs: src exposed-modules: Text.Email.Validate, Text.Email.Parser Test-Suite Main type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests x-uses-tf: true default-language: Haskell2010 build-depends: base >= 4 && < 5, HUnit >= 1.2 && < 2, email-validate, QuickCheck >= 2.4, test-framework >= 0.4.1, test-framework-quickcheck2, test-framework-hunit, bytestring >= 0.9 email-validate-2.1.3/tests/0000755000000000000000000000000012531772133013727 5ustar0000000000000000email-validate-2.1.3/tests/Main.hs0000644000000000000000000005023312531772133015152 0ustar0000000000000000module Main where import Text.Email.Validate import Test.HUnit import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Test.Framework as TF (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck main :: IO () main = defaultMain tests tests :: [TF.Test] tests = [ testGroup "EmailAddress Show/Read instances" [ testProperty "showLikeByteString" prop_showLikeByteString, testProperty "showAndReadBackWithoutQuoteFails" prop_showAndReadBackWithoutQuoteFails, testProperty "showAndReadBack" prop_showAndReadBack ], testGroup "QuickCheck Text.Email.Validate" [ testProperty "doubleCanonicalize" prop_doubleCanonicalize ], testGroup "Unit tests Text.Email.Validate" $ flip concatMap units (\(em, valid, _) -> let email = BS.pack em in [ testCase ("doubleCanonicalize '" ++ em ++ "'") (True @=? case emailAddress email of { Nothing -> True; Just ok -> prop_doubleCanonicalize ok }), testCase ("validity test '" ++ em ++ "'") (valid @=? isValid email) ]), testGroup "Issues" [ testCase "#12" (let (Right em) = validate (BS.pack "\"\"@1") in em @=? read (show em)) ] ] instance Arbitrary ByteString where arbitrary = fmap BS.pack arbitrary instance Arbitrary EmailAddress where arbitrary = do local <- suchThat arbitrary (\x -> isEmail x (BS.pack "example.com")) domain <- suchThat arbitrary (isEmail (BS.pack "example")) let email = makeEmailLike local domain let (Just result) = emailAddress email return result isEmail :: ByteString -> ByteString -> Bool isEmail l d = isValid (makeEmailLike l d) makeEmailLike :: ByteString -> ByteString -> ByteString makeEmailLike l d = BS.concat [l, BS.singleton '@', d] prop_doubleCanonicalize :: EmailAddress -> Bool prop_doubleCanonicalize email = Just email == emailAddress (toByteString email) prop_showLikeByteString :: EmailAddress -> Bool prop_showLikeByteString email = show (toByteString email) == show email prop_showAndReadBack :: EmailAddress -> Bool prop_showAndReadBack email = read (show email) == email readMaybe :: String -> Maybe EmailAddress readMaybe s = case reads s of [(x, "")] -> Just x _ -> Nothing prop_showAndReadBackWithoutQuoteFails :: EmailAddress -> Bool prop_showAndReadBackWithoutQuoteFails email = readMaybe (init s) == Nothing && readMaybe (tail s) == Nothing where s = show email --unitTest (x, y, z) = if not (isValid (BS.pack x) == y) then "" else (x ++" became "++ (case emailAddress (BS.pack x) of {Nothing -> "fail"; Just em -> show em}) ++": Should be "++show y ++", got "++show (not y)++"\n\t"++z++"\n") units :: [(String, Bool, String)] units = [ ("first.last@example.com", True, ""), ("1234567890123456789012345678901234567890123456789012345678901234@example.com", True, ""), ("\"first last\"@example.com", True, ""), ("\"first\\\"last\"@example.com", True, ""), ("first\\@last@example.com", False, "Escaping can only happen within a quoted string"), ("\"first@last\"@example.com", True, ""), ("\"first\\\\last\"@example.com", True, ""), ("x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x234", True, ""), ("123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.123456789012345678901234567890123456789012345678901234567890123.example.com", True, ""), ("first.last@[12.34.56.78]", True, ""), ("first.last@[IPv6:::12.34.56.78]", True, ""), ("first.last@[IPv6:1111:2222:3333::4444:12.34.56.78]", True, ""), ("first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.56.78]", True, ""), ("first.last@[IPv6:::1111:2222:3333:4444:5555:6666]", True, ""), ("first.last@[IPv6:1111:2222:3333::4444:5555:6666]", True, ""), ("first.last@[IPv6:1111:2222:3333:4444:5555:6666::]", True, ""), ("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888]", True, ""), ("first.last@x23456789012345678901234567890123456789012345678901234567890123.example.com", True, ""), ("first.last@1xample.com", True, ""), ("first.last@123.example.com", True, ""), ("first.last", False, "No @"), (".first.last@example.com", False, "Local part starts with a dot"), ("first.last.@example.com", False, "Local part ends with a dot"), ("first..last@example.com", False, "Local part has consecutive dots"), ("\"first\"last\"@example.com", False, "Local part contains unescaped excluded characters"), ("\"first\\last\"@example.com", True, "Any character can be escaped in a quoted string"), ("\"\"\"@example.com", False, "Local part contains unescaped excluded characters"), ("\"\\\"@example.com", False, "Local part cannot end with a backslash"), ("first\\\\@last@example.com", False, "Local part contains unescaped excluded characters"), ("first.last@", False, "No domain"), ("\"Abc\\@def\"@example.com", True, ""), ("\"Fred\\ Bloggs\"@example.com", True, ""), ("\"Joe.\\\\Blow\"@example.com", True, ""), ("\"Abc@def\"@example.com", True, ""), ("\"Fred Bloggs\"@example.com", True, ""), ("user+mailbox@example.com", True, ""), ("customer/department=shipping@example.com", True, ""), ("$A12345@example.com", True, ""), ("!def!xyz%abc@example.com", True, ""), ("_somename@example.com", True, ""), ("dclo@us.ibm.com", True, ""), ("abc\\@def@example.com", False, "This example from RFC3696 was corrected in an erratum"), ("abc\\\\@example.com", False, "This example from RFC3696 was corrected in an erratum"), ("peter.piper@example.com", True, ""), ("Doug\\ \\\"Ace\\\"\\ Lovell@example.com", False, "Escaping can only happen in a quoted string"), ("\"Doug \\\"Ace\\\" L.\"@example.com", True, ""), ("abc@def@example.com", False, "Doug Lovell says this should fail"), ("abc\\\\@def@example.com", False, "Doug Lovell says this should fail"), ("abc\\@example.com", False, "Doug Lovell says this should fail"), ("@example.com", False, "No local part"), ("doug@", False, "Doug Lovell says this should fail"), ("\"qu@example.com", False, "Doug Lovell says this should fail"), ("ote\"@example.com", False, "Doug Lovell says this should fail"), (".dot@example.com", False, "Doug Lovell says this should fail"), ("dot.@example.com", False, "Doug Lovell says this should fail"), ("two..dot@example.com", False, "Doug Lovell says this should fail"), ("\"Doug \"Ace\" L.\"@example.com", False, "Doug Lovell says this should fail"), ("Doug\\ \\\"Ace\\\"\\ L\\.@example.com", False, "Doug Lovell says this should fail"), ("hello world@example.com", False, "Doug Lovell says this should fail"), ("gatsby@f.sc.ot.t.f.i.tzg.era.l.d.", False, "Doug Lovell says this should fail"), ("test@example.com", True, ""), ("TEST@example.com", True, ""), ("1234567890@example.com", True, ""), ("test+test@example.com", True, ""), ("test-test@example.com", True, ""), ("t*est@example.com", True, ""), ("+1~1+@example.com", True, ""), ("{_test_}@example.com", True, ""), ("\"[[ test ]]\"@example.com", True, ""), ("test.test@example.com", True, ""), ("\"test.test\"@example.com", True, ""), ("test.\"test\"@example.com", True, "Obsolete form, but documented in RFC2822"), ("\"test@test\"@example.com", True, ""), ("test@123.123.123.x123", True, ""), ("test@[123.123.123.123]", True, ""), ("test@example.example.com", True, ""), ("test@example.example.example.com", True, ""), ("test.example.com", False, ""), ("test.@example.com", False, ""), ("test..test@example.com", False, ""), (".test@example.com", False, ""), ("test@test@example.com", False, ""), ("test@@example.com", False, ""), ("-- test --@example.com", False, "No spaces allowed in local part"), ("[test]@example.com", False, "Square brackets only allowed within quotes"), ("\"test\\test\"@example.com", True, "Any character can be escaped in a quoted string"), ("\"test\"test\"@example.com", False, "Quotes cannot be nested"), ("()[]\\;:,><@example.com", False, "Disallowed Characters"), ("test@.", False, "Dave Child says so"), ("test@example.", False, "Dave Child says so"), ("test@.org", False, "Dave Child says so"), ("test@[123.123.123.123", False, "Dave Child says so"), ("test@123.123.123.123]", False, "Dave Child says so"), ("NotAnEmail", False, "Phil Haack says so"), ("@NotAnEmail", False, "Phil Haack says so"), ("\"test\\\\blah\"@example.com", True, ""), ("\"test\\blah\"@example.com", True, "Any character can be escaped in a quoted string"), ("\"test\\\rblah\"@example.com", True, "Quoted string specifically excludes carriage returns unless escaped"), ("\"test\rblah\"@example.com", False, "Quoted string specifically excludes carriage returns"), ("\"test\\\"blah\"@example.com", True, ""), ("\"test\"blah\"@example.com", False, "Phil Haack says so"), ("customer/department@example.com", True, ""), ("_Yosemite.Sam@example.com", True, ""), ("~@example.com", True, ""), (".wooly@example.com", False, "Phil Haack says so"), ("wo..oly@example.com", False, "Phil Haack says so"), ("pootietang.@example.com", False, "Phil Haack says so"), (".@example.com", False, "Phil Haack says so"), ("\"Austin@Powers\"@example.com", True, ""), ("Ima.Fool@example.com", True, ""), ("\"Ima.Fool\"@example.com", True, ""), ("\"Ima Fool\"@example.com", True, ""), ("Ima Fool@example.com", False, "Phil Haack says so"), ("phil.h\\@\\@ck@haacked.com", False, "Escaping can only happen in a quoted string"), ("\"first\".\"last\"@example.com", True, ""), ("\"first\".middle.\"last\"@example.com", True, ""), ("\"first\\\\\"last\"@example.com", False, "Contains an unescaped quote"), ("\"first\".last@example.com", True, "obs-local-part form as described in RFC 2822"), ("first.\"last\"@example.com", True, "obs-local-part form as described in RFC 2822"), ("\"first\".\"middle\".\"last\"@example.com", True, "obs-local-part form as described in RFC 2822"), ("\"first.middle\".\"last\"@example.com", True, "obs-local-part form as described in RFC 2822"), ("\"first.middle.last\"@example.com", True, "obs-local-part form as described in RFC 2822"), ("\"first..last\"@example.com", True, "obs-local-part form as described in RFC 2822"), ("foo@[\\1.2.3.4]", False, "RFC 5321 specifies the syntax for address-literal and does not allow escaping"), ("\"first\\\\\\\"last\"@example.com", True, ""), ("first.\"mid\\dle\".\"last\"@example.com", True, "Backslash can escape anything but must escape something"), ("Test.\r\n Folding.\r\n Whitespace@example.com", True, ""), ("first\\last@example.com", False, "Unquoted string must be an atom"), ("Abc\\@def@example.com", False, "Was incorrectly given as a valid address in the original RFC3696"), ("Fred\\ Bloggs@example.com", False, "Was incorrectly given as a valid address in the original RFC3696"), ("Joe.\\\\Blow@example.com", False, "Was incorrectly given as a valid address in the original RFC3696"), ("\"test\\\r\n blah\"@example.com", False, "Folding white space can\'t appear within a quoted pair"), ("\"test\r\n blah\"@example.com", True, "This is a valid quoted string with folding white space"), ("{^c\\@**Dog^}@cartoon.com", False, "This is a throwaway example from Doug Lovell\'s article. Actually it\'s not a valid address."), ("(foo)cal(bar)@(baz)iamcal.com(quux)", True, "A valid address containing comments"), ("cal@iamcal(woo).(yay)com", True, "A valid address containing comments"), ("cal(woo(yay)hoopla)@iamcal.com", True, "A valid address containing comments"), ("cal(foo\\@bar)@iamcal.com", True, "A valid address containing comments"), ("cal(foo\\)bar)@iamcal.com", True, "A valid address containing comments and an escaped parenthesis"), ("cal(foo(bar)@iamcal.com", False, "Unclosed parenthesis in comment"), ("cal(foo)bar)@iamcal.com", False, "Too many closing parentheses"), ("cal(foo\\)@iamcal.com", False, "Backslash at end of comment has nothing to escape"), ("first().last@example.com", True, "A valid address containing an empty comment"), ("first.(\r\n middle\r\n )last@example.com", True, "Comment with folding white space"), ("first(12345678901234567890123456789012345678901234567890)last@(1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890)example.com", False, "Too long with comments, not too long without"), ("first(Welcome to\r\n the (\"wonderful\" (!)) world\r\n of email)@example.com", True, "Silly example from my blog post"), ("pete(his account)@silly.test(his host)", True, "Canonical example from RFC5322"), ("c@(Chris\'s host.)public.example", True, "Canonical example from RFC5322"), ("jdoe@machine(comment). example", True, "Canonical example from RFC5322"), ("1234 @ local(blah) .machine .example", True, "Canonical example from RFC5322"), ("first(middle)last@example.com", False, "Can\'t have a comment or white space except at an element boundary"), ("first(abc.def).last@example.com", True, "Comment can contain a dot"), ("first(a\"bc.def).last@example.com", True, "Comment can contain double quote"), ("first.(\")middle.last(\")@example.com", True, "Comment can contain a quote"), ("first(abc(\"def\".ghi).mno)middle(abc(\"def\".ghi).mno).last@(abc(\"def\".ghi).mno)example(abc(\"def\".ghi).mno).(abc(\"def\".ghi).mno)com(abc(\"def\".ghi).mno)", False, "Can\'t have comments or white space except at an element boundary"), ("first(abc\\(def)@example.com", True, "Comment can contain quoted-pair"), ("first.last@x(1234567890123456789012345678901234567890123456789012345678901234567890).com", True, "Label is longer than 63 octets, but not with comment removed"), ("a(a(b(c)d(e(f))g)h(i)j)@example.com", True, ""), ("a(a(b(c)d(e(f))g)(h(i)j)@example.com", False, "Braces are not properly matched"), ("name.lastname@domain.com", True, ""), (".@", False, ""), ("@bar.com", False, ""), ("@@bar.com", False, ""), ("a@bar.com", True, ""), ("aaa.com", False, ""), ("aaa@.com", False, ""), ("aaa@.123", False, ""), ("aaa@[123.123.123.123]", True, ""), ("aaa@[123.123.123.123]a", False, "extra data outside ip"), ("a@bar.com.", False, ""), ("a-b@bar.com", True, ""), ("+@b.c", True, "TLDs can be any length"), ("+@b.com", True, ""), ("-@..com", False, ""), ("-@a..com", False, ""), ("a@b.co-foo.uk", True, ""), ("\"hello my name is\"@stutter.com", True, ""), ("\"Test \\\"Fail\\\" Ing\"@example.com", True, ""), ("valid@special.museum", True, ""), ("shaitan@my-domain.thisisminekthx", True, "Disagree with Paul Gregg here"), ("test@...........com", False, "......"), ("\"Joe\\\\Blow\"@example.com", True, ""), ("Invalid \\\n Folding \\\n Whitespace@example.com", False, "This isn\'t FWS so Dominic Sayers says it\'s invalid"), ("HM2Kinsists@(that comments are allowed)this.is.ok", True, ""), ("user%uucp!path@somehost.edu", True, ""), ("\"first(last)\"@example.com", True, ""), (" \r\n (\r\n x \r\n ) \r\n first\r\n ( \r\n x\r\n ) \r\n .\r\n ( \r\n x) \r\n last \r\n ( x \r\n ) \r\n @example.com", True, ""), ("test.\r\n \r\n obs@syntax.com", True, "obs-fws allows multiple lines"), ("test. \r\n \r\n obs@syntax.com", True, "obs-fws allows multiple lines (test 2: space before break)"), ("test.\r\n\r\n obs@syntax.com", False, "obs-fws must have at least one WSP per line"), ("\"null \\\0\"@char.com", True, "can have escaped null character"), ("\"null \0\"@char.com", False, "cannot have unescaped null character") -- items below here are invalid according to other RFCs (or opinions) --("\"\"@example.com", False, "Local part is effectively empty"), --("foobar@192.168.0.1", False, "ip need to be []"), --("first.last@[.12.34.56.78]", False, "Only char that can precede IPv4 address is \':\'"), --("first.last@[12.34.56.789]", False, "Can\'t be interpreted as IPv4 so IPv6 tag is missing"), --("first.last@[::12.34.56.78]", False, "IPv6 tag is missing"), --("first.last@[IPv5:::12.34.56.78]", False, "IPv6 tag is wrong"), --("first.last@[IPv6:1111:2222:3333::4444:5555:12.34.56.78]", False, "Too many IPv6 groups (4 max)"), --("first.last@[IPv6:1111:2222:3333:4444:5555:12.34.56.78]", False, "Not enough IPv6 groups"), --("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:12.34.56.78]", False, "Too many IPv6 groups (6 max)"), --("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777]", False, "Not enough IPv6 groups"), --("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888:9999]", False, "Too many IPv6 groups (8 max)"), --("first.last@[IPv6:1111:2222::3333::4444:5555:6666]", False, "Too many \'::\' (can be none or one)"), --("first.last@[IPv6:1111:2222:3333::4444:5555:6666:7777]", False, "Too many IPv6 groups (6 max)"), --("first.last@[IPv6:1111:2222:333x::4444:5555]", False, "x is not valid in an IPv6 address"), --("first.last@[IPv6:1111:2222:33333::4444:5555]", False, "33333 is not a valid group in an IPv6 address"), --("first.last@example.123", False, "TLD can\'t be all digits"), --("aaa@[123.123.123.333]", False, "not a valid IP"), --("first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.567.89]", False, "IPv4 part contains an invalid octet"), --("a@b", False, ""), --("a@bar", False, ""), --("invalid@special.museum-", False, ""), --("a@-b.com", False, ""), --("a@b-.com", False, ""), --("\"foo\"(yay)@(hoopla)[1.2.3.4]", False, "Address literal can\'t be commented (RFC5321)"), --("first.\"\".last@example.com", False, "Contains a zero-length element"), --("test@example", False, "Dave Child says so"), --("12345678901234567890123456789012345678901234567890123456789012345@example.com", False, "Local part more than 64 characters"), --("x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456", False, "Domain exceeds 255 chars"), --("test@123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012.com", False, "255 characters is maximum length for domain. This is 256."), --("123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.1234.example.com", False, "Entire address is longer than 256 characters"), --("test@123.123.123.123", False, "Top Level Domain won\'t be all-numeric (see RFC3696 Section 2). I disagree with Dave Child on this one."), --("first.last@x234567890123456789012345678901234567890123456789012345678901234.example.com", False, "Label can\'t be longer than 63 octets"), --("first.last@com", False, "Mail host must be second- or lower level"), --("first.last@-xample.com", False, "Label can\'t begin with a hyphen"), --("first.last@exampl-.com", False, "Label can\'t end with a hyphen"), ] email-validate-2.1.3/src/0000755000000000000000000000000012531772133013354 5ustar0000000000000000email-validate-2.1.3/src/Text/0000755000000000000000000000000012531772133014300 5ustar0000000000000000email-validate-2.1.3/src/Text/Email/0000755000000000000000000000000012531772133015327 5ustar0000000000000000email-validate-2.1.3/src/Text/Email/Validate.hs0000644000000000000000000000221712531772133017416 0ustar0000000000000000module Text.Email.Validate ( isValid , validate , emailAddress , canonicalizeEmail , EmailAddress -- re-exported , localPart , domainPart , toByteString ) where import Control.Applicative ((<*)) import Data.ByteString (ByteString) import Data.Attoparsec.ByteString (parseOnly, endOfInput) import Text.Email.Parser (EmailAddress, toByteString, addrSpec, localPart, domainPart) -- | Smart constructor for an email address emailAddress :: ByteString -> Maybe EmailAddress emailAddress = either (const Nothing) Just . validate -- | Checks that an email is valid and returns a version of it -- where comments and whitespace have been removed. canonicalizeEmail :: ByteString -> Maybe ByteString canonicalizeEmail = fmap toByteString . emailAddress -- | Validates whether a particular string is an email address -- according to RFC5322. isValid :: ByteString -> Bool isValid = either (const False) (const True) . validate -- | If you want to find out *why* a particular string is not -- an email address, use this. validate :: ByteString -> Either String EmailAddress validate = parseOnly (addrSpec <* endOfInput) email-validate-2.1.3/src/Text/Email/Parser.hs0000644000000000000000000001031012531772133017112 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} module Text.Email.Parser ( addrSpec , localPart , domainPart , EmailAddress , toByteString ) where import Control.Applicative import Control.Monad (void) import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString) import Data.Attoparsec.ByteString.Char8 import Data.Data (Data, Typeable) import GHC.Generics (Generic) import qualified Text.Read as Read -- | Represents an email address. data EmailAddress = EmailAddress ByteString ByteString deriving (Eq, Ord, Data, Typeable, Generic) instance Show EmailAddress where show = show . toByteString instance Read EmailAddress where readListPrec = Read.readListPrecDefault readPrec = Read.parens (do bs <- Read.readPrec case parseOnly (addrSpec <* endOfInput) bs of Left _ -> Read.pfail Right a -> return a) -- | Converts an email address back to a ByteString toByteString :: EmailAddress -> ByteString toByteString (EmailAddress l d) = BS.concat [l, BS.singleton '@', d] -- | Extracts the local part of an email address. localPart :: EmailAddress -> ByteString localPart (EmailAddress l _) = l -- | Extracts the domain part of an email address. domainPart :: EmailAddress -> ByteString domainPart (EmailAddress _ d) = d -- | A parser for email addresses. addrSpec :: Parser EmailAddress addrSpec = do l <- local _ <- char '@' d <- domain return (EmailAddress l d) local :: Parser ByteString local = dottedAtoms domain :: Parser ByteString domain = dottedAtoms <|> domainLiteral dottedAtoms :: Parser ByteString dottedAtoms = BS.intercalate (BS.singleton '.') <$> between1 (optional cfws) (atom <|> quotedString) `sepBy1` char '.' atom :: Parser ByteString atom = takeWhile1 isAtomText isAtomText :: Char -> Bool isAtomText x = isAlphaNum x || inClass "!#$%&'*+/=?^_`{|}~-" x domainLiteral :: Parser ByteString domainLiteral = (BS.cons '[' . flip BS.snoc ']' . BS.concat) <$> between (optional cfws *> char '[') (char ']' <* optional cfws) (many (optional fws >> takeWhile1 isDomainText) <* optional fws) isDomainText :: Char -> Bool isDomainText x = inClass "\33-\90\94-\126" x || isObsNoWsCtl x quotedString :: Parser ByteString quotedString = (\x -> BS.concat [BS.singleton '"', BS.concat x, BS.singleton '"']) <$> between (char '"') (char '"') (many (optional fws >> quotedContent) <* optional fws) quotedContent :: Parser ByteString quotedContent = takeWhile1 isQuotedText <|> quotedPair isQuotedText :: Char -> Bool isQuotedText x = inClass "\33\35-\91\93-\126" x || isObsNoWsCtl x quotedPair :: Parser ByteString quotedPair = (BS.cons '\\' . BS.singleton) <$> (char '\\' *> (vchar <|> wsp <|> lf <|> cr <|> obsNoWsCtl <|> nullChar)) cfws :: Parser () cfws = skipMany (comment <|> fws) fws :: Parser () fws = void (wsp1 >> optional (crlf >> wsp1)) <|> (skipMany1 (crlf >> wsp1)) between :: Applicative f => f l -> f r -> f a -> f a between l r x = l *> x <* r between1 :: Applicative f => f lr -> f a -> f a between1 lr x = lr *> x <* lr comment :: Parser () comment = between (char '(') (char ')') $ skipMany (void commentContent <|> fws) commentContent :: Parser () commentContent = skipWhile1 isCommentText <|> void quotedPair <|> comment isCommentText :: Char -> Bool isCommentText x = inClass "\33-\39\42-\91\93-\126" x || isObsNoWsCtl x nullChar :: Parser Char nullChar = char '\0' skipWhile1 :: (Char -> Bool) -> Parser() skipWhile1 x = satisfy x >> skipWhile x wsp1 :: Parser () wsp1 = skipWhile1 isWsp wsp :: Parser Char wsp = satisfy isWsp isWsp :: Char -> Bool isWsp x = x == ' ' || x == '\t' isAlphaNum :: Char -> Bool isAlphaNum x = isDigit x || isAlpha_ascii x cr :: Parser Char cr = char '\r' lf :: Parser Char lf = char '\n' crlf :: Parser () crlf = void $ cr >> lf isVchar :: Char -> Bool isVchar = inClass "\x21-\x7e" vchar :: Parser Char vchar = satisfy isVchar isObsNoWsCtl :: Char -> Bool isObsNoWsCtl = inClass "\1-\8\11-\12\14-\31\127" obsNoWsCtl :: Parser Char obsNoWsCtl = satisfy isObsNoWsCtl