email-validate-1.0.0/0000755000000000000000000000000012103076323012551 5ustar0000000000000000email-validate-1.0.0/Setup.lhs0000644000000000000000000000011712103076323014360 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain email-validate-1.0.0/LICENSE0000644000000000000000000000271712103076323013565 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-1.0.0/email-validate.cabal0000644000000000000000000000233112103076323016412 0ustar0000000000000000name: email-validate version: 1.0.0 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.8 source-repository head type: git location: git://github.com/Porges/email-validate-hs.git library build-depends: base >= 4 && < 5, attoparsec >= 0.10.0, bytestring >= 0.9 ghc-options: -O2 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 test-module Test.Text.Email.Validate x-uses-tf: true 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.9email-validate-1.0.0/tests/0000755000000000000000000000000012103076323013713 5ustar0000000000000000email-validate-1.0.0/tests/Main.hs0000644000000000000000000004575212103076323015150 0ustar0000000000000000module Main where import Data.Maybe (catMaybes) 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 "QuickCheck Text.Email.Validate" [ testProperty "doubleCanonicalize" prop_doubleCanonicalize ], testGroup "Unit tests Text.Email.Validate" $ flip concatMap units (\(em, valid, why) -> 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) ]) ] 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 (\x -> isEmail (BS.pack "example") x) let email = makeEmailLike local domain let (Just result) = emailAddress email return result isEmail l d = isValid (makeEmailLike l d) makeEmailLike l d = BS.concat [l, BS.singleton '@', d] prop_doubleCanonicalize email = Just email == emailAddress (toByteString 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 = [ ("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-1.0.0/src/0000755000000000000000000000000012103076323013340 5ustar0000000000000000email-validate-1.0.0/src/Text/0000755000000000000000000000000012103076323014264 5ustar0000000000000000email-validate-1.0.0/src/Text/Email/0000755000000000000000000000000012103076323015313 5ustar0000000000000000email-validate-1.0.0/src/Text/Email/Validate.hs0000644000000000000000000000214212103076323017377 0ustar0000000000000000module Text.Email.Validate (isValid ,validate ,emailAddress ,canonicalizeEmail ,EmailAddress -- re-exported ,localPart ,domainPart ,toByteString) where import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString) import Data.Attoparsec (parseOnly) import Text.Email.Parser -- | Smart constructor for an email address emailAddress :: ByteString -> Maybe EmailAddress emailAddress x = case validate x of Left _ -> Nothing Right em -> Just em -- | 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 x = let result = validate x in either (const False) (const True) result -- | 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 email-validate-1.0.0/src/Text/Email/Parser.hs0000644000000000000000000000565012103076323017111 0ustar0000000000000000module Text.Email.Parser (addrSpec ,localPart ,domainPart ,EmailAddress ,toByteString) where import Control.Applicative import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString) import Data.Char (chr) import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinator -- | Represents an email address. data EmailAddress = EmailAddress ByteString ByteString deriving (Eq,Ord) instance Show EmailAddress where show = BS.unpack . toByteString -- | Converts an email address back to a ByteString toByteString (EmailAddress l d) = BS.concat [l, BS.singleton '@', d] -- | Extracts the local part of an email address. localPart :: EmailAddress -> ByteString localPart (EmailAddress local _) = local -- | Extracts the domain part of an email address. domainPart :: EmailAddress -> ByteString domainPart (EmailAddress _ domain) = domain -- | A parser for email addresses. addrSpec = do localPart <- local char '@' domainPart <- domain endOfInput return (EmailAddress localPart domainPart) local = dottedAtoms domain = dottedAtoms <|> domainLiteral dottedAtoms = BS.intercalate (BS.singleton '.') <$> (optional cfws *> (atom <|> quotedString) <* optional cfws) `sepBy1` (char '.') atom = takeWhile1 isAtomText isAtomText x = isAlphaNum x || inClass "!#$%&'*+/=?^_`{|}~-" x domainLiteral = (BS.cons '[' . flip BS.snoc ']' . BS.concat) <$> (between (optional cfws *> char '[') (char ']' <* optional cfws) $ many (optional fws >> takeWhile1 isDomainText) <* optional fws) isDomainText x = inClass "\33-\90\94-\126" x || isObsNoWsCtl x quotedString = (\x -> BS.concat $ [BS.singleton '"', BS.concat x, BS.singleton '"']) <$> (between (char '"') (char '"') $ many (optional fws >> quotedContent) <* optional fws) quotedContent = takeWhile1 isQuotedText <|> quotedPair isQuotedText x = inClass "\33\35-\91\93-\126" x || isObsNoWsCtl x quotedPair = (BS.cons '\\' . BS.singleton) <$> (char '\\' *> (vchar <|> wsp <|> lf <|> cr <|> obsNoWsCtl <|> nullChar)) cfws = ignore $ many (comment <|> fws) fws :: Parser () fws = ignore $ ignore (wsp1 >> optional (crlf >> wsp1)) <|> ignore (many1 (crlf >> wsp1)) ignore :: Parser a -> Parser () ignore x = x >> return () between l r x = l *> x <* r comment :: Parser () comment = ignore ((between (char '(') (char ')') $ many (ignore commentContent <|> fws))) commentContent = skipWhile1 isCommentText <|> ignore quotedPair <|> comment isCommentText x = inClass "\33-\39\42-\91\93-\126" x || isObsNoWsCtl x nullChar = char '\0' skipWhile1 x = satisfy x >> skipWhile x wsp1 = skipWhile1 isWsp wsp = satisfy isWsp isWsp x = x == ' ' || x == '\t' isAlphaNum x = isDigit x || isAlpha_ascii x cr = char '\r' lf = char '\n' crlf = cr >> lf >> return () isVchar = inClass "\x21-\x7e" vchar = satisfy isVchar isObsNoWsCtl = inClass "\1-\8\11-\12\14-\31\127" obsNoWsCtl = satisfy isObsNoWsCtl