diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,7 @@ +Release History +=============== + +[0.1.0] - 2020-05-08 +-------------------- + + * Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2020 Peter J. Jones +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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +Addy: a modern library for working with email addresses +======================================================= + +[![addy](https://circleci.com/gh/pjones/addy.svg?style=shield)](https://app.circleci.com/github/pjones/addy/pipelines) +[![Hackage](https://img.shields.io/hackage/v/addy?logo=haskell)](https://hackage.haskell.org/package/addy) +[![GitHub](https://img.shields.io/github/license/pjones/addy)](https://github.com/pjones/addy/blob/master/LICENSE) + +A full-featured library for parsing, validating, and rendering email +addresses. + +Decoding +-------- + +```haskell +Addy.decode "example@example.com" +-- Right (EmailAddr "example@example.com") + +Addy.decode "我買@屋企.香港" +-- Right (EmailAddr "\25105\36023@\23627\20225.\39321\28207") + +Addy.decode "Mary Smith (hi there!)" +-- Right (EmailAddr "Mary Smith (hi there!)") + +Addy.decode "example@[127.0.0.1]" +-- Right (EmailAddr "example@[127.0.0.1]") +``` + +Encoding +-------- + +```haskell +Addy.encode address +-- "example@example.com" + +Addy.decode "Mary Smith (hi there!)" + & second Addy.encodeFull +-- Right "Mary Smith (hi there!)" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,16 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +import Distribution.Simple +main = defaultMain diff --git a/addy.cabal b/addy.cabal new file mode 100644 --- /dev/null +++ b/addy.cabal @@ -0,0 +1,126 @@ +cabal-version: 2.2 + +-------------------------------------------------------------------------------- +name: addy +version: 0.1.0.0 +synopsis: A full-featured library for parsing, validating, and rendering email addresses +license: BSD-2-Clause +license-file: LICENSE +author: Peter Jones +maintainer: Peter Jones +copyright: Copyright (c) 2019-2020 Peter Jones +homepage: https://github.com/pjones/addy +bug-reports: https://github.com/pjones/addy/issues +category: Text +tested-with: GHC == 8.6.5, GHC == 8.8.3 +build-type: Simple +description: + A modern library for working with email addresses. This package can + be used to validate user input or handle various flavors of + addresses that appear in places such as mail messages. + . + Email addresses can be decoded, manipulated, then rendered back to + text using the simple @local-part\@domain@ format or the more + complete syntax that allows for display names and comments. + . + Comprehensive documentation can be found in the "Addy" module. + +-------------------------------------------------------------------------------- +extra-source-files: + README.md + CHANGES.md + test/isemail.json + test/README.md + +-------------------------------------------------------------------------------- +common options + default-language: Haskell2010 + + default-extensions: + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + + ghc-options: + -Wall + -Wno-name-shadowing + -Werror=incomplete-record-updates + -Werror=incomplete-uni-patterns + -Werror=missing-home-modules + -Widentities + -Wmissing-export-lists + -Wredundant-constraints + +-------------------------------------------------------------------------------- +common dependencies + build-depends: + attoparsec >= 0.13 && < 0.14, + base >= 4.9 && < 5.0, + bytestring >= 0.10 && < 0.11, + ip >= 1.5.1 && < 1.8, + lens >= 4.17 && < 5.0, + relude >= 0.6 && < 0.7, + text >= 1.2 && < 1.3, + text-icu >= 0.7 && < 0.8, + validation-selective >= 0.1 && < 0.2 + + mixins: base hiding (Prelude) + , relude (Relude as Prelude) + +-------------------------------------------------------------------------------- +library + import: options, dependencies + hs-source-dirs: src + exposed-modules: + Addy + Addy.Internal.Char + Addy.Internal.Parser + Addy.Internal.Render + Addy.Internal.Types + Addy.Internal.Validation + +-------------------------------------------------------------------------------- +test-suite test + import: options, dependencies + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + ParserTest + RenderTest + TestData + build-depends: + addy, + aeson >= 1.4, + hedgehog >= 1.0 && < 1.1, + http-types >= 0.12, + tasty >= 1.1 && < 1.3, + tasty-hedgehog >= 1.0 && < 1.1, + tasty-hunit >= 0.10 && < 0.11 + +-------------------------------------------------------------------------------- +-- test-suite doctests +-- import: options, dependencies +-- type: exitcode-stdio-1.0 +-- ghc-options: -threaded +-- hs-source-dirs: test/docs +-- main-is: Main.hs +-- build-depends: doctest >= 0.16 diff --git a/src/Addy.hs b/src/Addy.hs new file mode 100644 --- /dev/null +++ b/src/Addy.hs @@ -0,0 +1,437 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +-- +-- Email addressed are complicated, really complicated. This library +-- supports all standardized forms of email addresses, including those +-- with UTF-8 encoded Unicode characters. The standards used by this +-- library include: +-- +-- * RFC 1123: Requirements for Internet Hosts -- Application and Support +-- * RFC 2181: Clarifications to the DNS Specification +-- * RFC 3696: Application Techniques for Checking and Transformation of Names +-- * RFC 5321: Simple Mail Transfer Protocol +-- * RFC 5322: Internet Message Format +-- * RFC 6531: SMTP Extension for Internationalized Email +-- * RFC 6532: Internationalized Email Headers +module Addy + ( -- * How to use this library + -- $use + + -- * Decoding and encoding + decode, + decodeLenient, + encode, + encodeFull, + + -- * Email addresses + EmailAddr, + emailAddr, + emailAddrLit, + displayName, + localPart, + domain, + comments, + + -- * Display name + DisplayName, + _DisplayName, + validateDisplayName, + + -- * Local part + LocalPart, + _LocalPart, + validateLocalPart, + + -- * Domain part + Domain (..), + _Domain, + _DomainLiteral, + DomainName, + _DomainName, + validateDomainName, + + -- * Host names + HostName, + _HostNames, + _HostName, + validateHostName, + + -- * Address literals + AddressLiteral (..), + _IpAddressLiteral, + _TaggedAddressLiteral, + _AddressLiteral, + AddressTag, + _AddressTag, + validateAddressTag, + Literal, + _Literal, + validateLiteral, + + -- * Comments + Comment (..), + _Comment, + commentLoc, + commentContent, + CommentLoc (..), + CommentContent, + _CommentContent, + validateCommentContent, + ) +where + +import Addy.Internal.Parser as P +import Addy.Internal.Render as R +import Addy.Internal.Types +import Addy.Internal.Validation +import Control.Lens (Prism', prism') +import Validation.Combinators (successToMaybe) + +-- | Decode an email address. +-- +-- @since 0.1.0.0 +decode :: Text -> Either (NonEmpty Error) EmailAddr +decode = P.parseWithMode P.Strict + +-- | Decode an email address, allowing obsolete characters. The +-- obsolete characters are parsed but not included in the output. +-- +-- This is useful for exacting email addresses from mail messages but +-- should not be used to validate user input. +-- +-- >>> Addy.decode "my . email . addy@(WTF)example.com" +-- Left (ParserFailedError "local part > quoted content > '\"': Failed reading: satisfy" :| []) +-- +-- >>> Addy.decodeLenient "my . email . addy@(WTF)example.com" +-- Right (EmailAddr "my.email.addy@example.com (WTF)") +-- +-- @since 0.1.0.0 +decodeLenient :: Text -> Either (NonEmpty Error) EmailAddr +decodeLenient = P.parseWithMode P.Lenient + +-- | Encode an email address as text. This function produces the +-- short form of an email address. That is, just the 'LocalPart' and +-- the 'Domain' separated by @\@@. +-- +-- @since 0.1.0.0 +encode :: EmailAddr -> Text +encode = R.renderToText R.Short + +-- | Encode a complete email address to text, including the optional +-- display name and any comments. +-- +-- @since 0.1.0.0 +encodeFull :: EmailAddr -> Text +encodeFull = R.renderToText R.Full + +-- | Build an 'EmailAddr' from a 'LocalPart' and 'DomainName'. +-- +-- @since 0.1.0.0 +emailAddr :: LocalPart -> DomainName -> EmailAddr +emailAddr l d = EmailAddr Nothing l (Domain d) [] + +-- | Build an 'EmailAddr' from a 'LocalPart' and an 'AddressLiteral'. +-- +-- @since 0.1.0.0 +emailAddrLit :: LocalPart -> AddressLiteral -> EmailAddr +emailAddrLit l d = EmailAddr Nothing l (DomainLiteral d) [] + +-- | Prism for working with display names. +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text into a 'DisplayName' with content validation: +-- +-- >>> "Some Text" ^? _DisplayName +-- Just (DisplayName "Some Text") +-- >>> "Some\nText" ^? _DisplayName +-- Nothing -- Validation failed. +-- +-- To access the text content of a 'DisplayName': +-- +-- >>> review _DisplayName someDisplayName +-- "Some Text" +-- +-- Uses 'validateDisplayName' to perform validation. +-- +-- @since 0.1.0.0 +_DisplayName :: Prism' Text DisplayName +_DisplayName = + prism' + displayNameText + (validateDisplayName >>> successToMaybe) + +-- | Prism for working with the local part of an email address. +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text to a 'LocalPart' with content validation: +-- +-- >>> "cockroach+mouse" ^? _LocalPart +-- Just (LocalPart "cockroach+mouse") +-- >>> "cockroach\nmouse" ^? _LocalPart +-- Nothing -- Validation failed. +-- +-- To access the text content of a 'LocalPart': +-- +-- >>> review _LocalPart someLocalPart +-- "cockamouse" +-- +-- Uses 'validateLocalPart' to perform validation. +-- +-- @since 0.1.0.0 +_LocalPart :: Prism' Text LocalPart +_LocalPart = + prism' + localPartText + (validateLocalPart >>> successToMaybe) + +-- | Prism for working with domain names. +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text to a 'DomainName' with validation: +-- +-- >>> "gmail.com" ^? _DomainName +-- Just (DomainName "gmail.com") +-- >>> "too.many.dots." ^? _DomainName +-- Nothing +-- +-- To access the text content of a 'DomainName': +-- +-- >>> review _DomainName someDomainName +-- "gmail.com" +-- +-- Uses 'validateDomainName' to perform validation. +-- +-- @since 0.1.0.0 +_DomainName :: Prism' Text DomainName +_DomainName = + prism' + domainNameText + (validateDomainName >>> successToMaybe) + +-- | Prism for working with host names (DNS labels). +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text to a host name with validation: +-- +-- >>> "com" ^? _HostName +-- Just (HostName "com") +-- >>> "com." ^? _HostName +-- Nothing -- Validation failed. +-- +-- To access the text content of a 'HostName': +-- +-- >>> review _HostName someHostName +-- "com" +-- +-- Uses 'validateHostName' to perform validation. +-- +-- @since 0.1.0.0 +_HostName :: Prism' Text HostName +_HostName = + prism' + hostNameText + (validateHostName >>> successToMaybe) + +-- | Prism for working with the 'AddressTag' for an 'AddressLiteral'. +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text to an address tag with validation: +-- +-- >>> "IPv6" ^? _AddressTag +-- Just (AddressTag "IPv6") +-- >>> "[IPv6]" ^? _AddressTag +-- Nothing -- Validation failed. +-- +-- To access the text content of an 'AddressTag': +-- +-- >>> review _AddressTag someTag +-- "tag" +-- +-- Uses 'validateAddressTag' to perform validation. +-- +-- @since 0.1.0.0 +_AddressTag :: Prism' Text AddressTag +_AddressTag = + prism' + addressTagText + (validateAddressTag >>> successToMaybe) + +-- | Prism for working with the literal text of an address literal. +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text to an address literal with validation: +-- +-- >>> "127.0.0.1" ^? _Literal +-- Just (Literal "127.0.0.1") +-- >>> "[]" ^? _Literal +-- Nothing -- Validation failed. +-- +-- To access the text content of a 'Literal': +-- +-- >>> review _Literal someLiteral +-- "127.0.0.1" +-- +-- Uses 'validateLiteral' to perform validation. +-- +-- @since 0.1.0.0 +_Literal :: Prism' Text Literal +_Literal = + prism' + literalText + (validateLiteral >>> successToMaybe) + +-- | Prism for working with the text content of a comment. +-- +-- > import Control.Lens ((^?), review) +-- +-- To convert text to a comment with validation: +-- +-- >>> "best email ever" ^? _CommentContent +-- Just (CommentContent "best email ever") +-- >>> "\n" ^? _CommentContent +-- Nothing +-- +-- To access the text content of the comment: +-- +-- >>> review _CommentContent someComment +-- "super" +-- +-- Uses 'validateCommentContent' to perform validation. +-- +-- @since 0.1.0.0 +_CommentContent :: + Prism' Text CommentContent +_CommentContent = + prism' + commentContentText + (validateCommentContent >>> successToMaybe) + +-- $use +-- +-- == Importing +-- +-- This library is designed to be imported qualified: +-- +-- > import qualified Addy +-- +-- == Decoding addresses +-- +-- To decode (parse) an email address from text: +-- +-- >>> Addy.decode "example@example.com" +-- Right (EmailAddr "example@example.com") +-- +-- >>> Addy.decode "我買@屋企.香港" +-- Right (EmailAddr "\25105\36023@\23627\20225.\39321\28207") +-- +-- >>> Addy.decode "Mary Smith (hi there!)" +-- Right (EmailAddr "Mary Smith (hi there!)") +-- +-- >>> Addy.decode "example@[127.0.0.1]" +-- Right (EmailAddr "example@[127.0.0.1]") +-- +-- After decoding, an address is automatically normalized by performing +-- NFC normalization and down-casing the domain name: +-- +-- >>> Addy.decode "My.Email.Addy@ExAmPlE.COM" +-- Right (EmailAddr "My.Email.Addy@example.com") +-- +-- == Encoding addresses +-- +-- Turning an email address back to text is just as easy: +-- +-- >>> Addy.encode address +-- "example@example.com" +-- +-- If an address has an optional display name or comments you can +-- render those with the 'encodeFull' function. +-- +-- >>> :{ +-- Addy.decode "Mary Smith (hi there!)" +-- & second Addy.encodeFull +-- :} +-- Right "Mary Smith (hi there!)" +-- +-- == Creating addresses +-- +-- In order to prevent invalid email addresses from being created this +-- library uses @newtype@ wrappers and does not export the data +-- constructors. Therefore you'll need to use the smart constructor +-- approach using the 'emailAddr' function. +-- +-- If you want to work with the validation functions directly we +-- recommend 'Applicative' syntax: +-- +-- >>> :{ +-- Addy.emailAddr +-- <$> Addy.validateLocalPart "pjones" +-- <*> Addy.validateDomainName "devalot.com" +-- :} +-- Success (EmailAddr "pjones@devalot.com") +-- +-- Prisms for the @newtype@ wrappers are provided if you want to use optics: +-- +-- >>> :{ +-- Addy.emailAddr +-- <$> "pjones" ^? Addy._LocalPart +-- <*> "devalot.com" ^? Addy._DomainName +-- :} +-- Just (EmailAddr "pjones@devalot.com") +-- +-- == Optics +-- +-- Lens and prisms are provided to make working with email addresses easier: +-- +-- > import qualified Addy +-- > import Control.Lens +-- +-- >>> Addy.decode "example@example.com" ^? _Right . Addy.domain +-- Just (Domain (DomainName "example.com")) +-- +-- >>> Addy.decode "example@example.com" +-- ^? _Right . Addy.domain . Addy._Domain . Addy._HostNames +-- Just [HostName "example",HostName "com"] +-- +-- >>> Addy.decode "example@example.com" +-- ^.. _Right . Addy.domain . Addy._Domain +-- . Addy._HostNames . traversed . re _HostName +-- ["example","com"] +-- +-- == A word about address literals +-- +-- Believe it or not, this is a completely valid email address: +-- +-- >>> Addy.decode "example@[what's my domain name?]" +-- ^? _Right . Addy.domain +-- Just (DomainLiteral (AddressLiteral (Literal "what's my domain name?"))) +-- +-- If you're working with email messages it might be useful to capture +-- these address literals, especially if you know how to interpret +-- them. However, if you're validating user input you probably don't +-- want to allow these. +-- +-- >>> Addy.decode "e@[127.0.0.1]" ^? _Right +-- >>= failover (Addy.domain . Addy._Domain) id +-- Nothing +-- +-- >>> Addy.decode "example@example.com" ^? _Right +-- >>= failover (Addy.domain . Addy._Domain) id +-- Just (EmailAddr "example@example.com") diff --git a/src/Addy/Internal/Char.hs b/src/Addy/Internal/Char.hs new file mode 100644 --- /dev/null +++ b/src/Addy/Internal/Char.hs @@ -0,0 +1,224 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +-- +-- Internal functions representing character classes in email +-- addresses. +-- +-- Obsolete characters are only supported in +-- 'Addy.Internal.Parser.Lenient' mode and are filtered out after +-- parsing. +module Addy.Internal.Char + ( utf8NonAscii, + obsNoWsCtl, + wsp, + vchar, + atext, + dtext, + ctext, + ctextObs, + qtext, + qtextObs, + quotedPair, + quotedPairObs, + ) +where + +import Data.Char + +-- | Is a character in the @UTF8-non-ascii@ class from RFC 6532? +-- +-- @since 0.1.0.0 +utf8NonAscii :: Char -> Bool +utf8NonAscii c = ord c >= 0xc2 && isPrint c + +-- | Obsolete control characters. +-- +-- > obs-NO-WS-CTL = %d1-8 / ; US-ASCII control +-- > %d11 / ; characters that do not +-- > %d12 / ; include the carriage +-- > %d14-31 / ; return, line feed, and +-- > %d127 ; white space characters +-- +-- @since 0.1.0.0 +obsNoWsCtl :: Char -> Bool +obsNoWsCtl = ord >>> go + where + go n = + (n >= 1 && n <= 8) + || n == 11 + || n == 12 + || (n >= 14 && n <= 31) + || n == 127 + +-- | Whitepace. +-- +-- @since 0.1.0.0 +wsp :: Char -> Bool +wsp c = c == ' ' || c == '\t' + +-- | RFC 5234: Visible character. +-- +-- > VCHAR = %x21-7E +-- > ; visible (printing) characters +-- +-- RFC 6532 §3.2 +-- +-- > VCHAR =/ UTF8-non-ascii +-- +-- @since 0.1.0.0 +vchar :: Char -> Bool +vchar c = vchar' (ord c) || utf8NonAscii c + where + vchar' n = n >= 0x21 && n <= 0x7e + +-- | RFC 5322 §3.2.3 +-- +-- > atext = ALPHA / DIGIT / ; Printable US-ASCII +-- > "!" / "#" / ; characters not including +-- > "$" / "%" / ; specials. Used for atoms. +-- > "&" / "'" / +-- > "*" / "+" / +-- > "-" / "/" / +-- > "=" / "?" / +-- > "^" / "_" / +-- > "`" / "{" / +-- > "|" / "}" / +-- > "~" +-- +-- RFC 6532 §3.2 +-- +-- > atext =/ UTF8-non-ascii +-- +-- @since 0.1.0.0 +atext :: Char -> Bool +atext c = + isAlphaNum c + || utf8NonAscii c + || c == '!' + || c == '#' + || c == '$' + || c == '%' + || c == '&' + || c == '\'' + || c == '*' + || c == '+' + || c == '-' + || c == '/' + || c == '=' + || c == '?' + || c == '^' + || c == '_' + || c == '`' + || c == '{' + || c == '|' + || c == '}' + || c == '~' + +-- | RFC 5322 @dtext@. +-- +-- > dtext = %d33-90 / ; Printable US-ASCII +-- > %d94-126 / ; characters not including +-- > obs-dtext ; "[", "]", or "\" +-- > obs-dtext = obs-NO-WS-CTL / quoted-pair +-- +-- RFC 6532 §3.2 +-- +-- > dtext =/ UTF8-non-ascii +-- @since 0.1.0.0 +dtext :: Char -> Bool +dtext c = asciidtext (ord c) || utf8NonAscii c + where + asciidtext n = + (n >= 33 && n <= 90) + || (n >= 94 && n <= 126) + +-- | RFC 5322 @ctext@. +-- +-- > ctext = %d33-39 / ; Printable US-ASCII +-- > %d42-91 / ; characters not including +-- > %d93-126 / ; "(", ")", or "\" +-- > obs-ctext +-- > +-- > obs-ctext = obs-NO-WS-CTL +-- +-- RFC 6532 §3.2 +-- +-- > ctext =/ UTF8-non-ascii +-- +-- @since 0.1.0.0 +ctext :: Char -> Bool +ctext c = asciictext (ord c) || utf8NonAscii c + where + asciictext n = + (n >= 33 && n <= 39) + || (n >= 42 && n <= 91) + || (n >= 93 && n <= 126) + +-- | Obsolete @ctext@. +-- +-- > obs-ctext = obs-NO-WS-CTL +-- +-- @since 0.1.0.0 +ctextObs :: Char -> Bool +ctextObs = obsNoWsCtl + +-- | Characters that can appear in a quoted string. +-- +-- RFC 5322 §3.2.4: +-- +-- > qtext = %d33 / ; Printable US-ASCII +-- > %d35-91 / ; characters not including +-- > %d93-126 / ; "\" or the quote character +-- > obs-qtext +-- +-- RFC 6532 §3.2: +-- +-- > qtext =/ UTF8-non-ascii +-- @since 0.1.0.0 +qtext :: Char -> Bool +qtext c = asciiqtext (ord c) || utf8NonAscii c + where + asciiqtext n = + n == 33 + || (n >= 35 && n <= 91) + || (n >= 93 && n <= 126) + +-- | Obsolete @qtext@. +-- +-- > obs-qtext = obs-NO-WS-CTL +-- +-- @since 0.1.0.0 +qtextObs :: Char -> Bool +qtextObs = obsNoWsCtl + +-- | Characters that can follow a backslash. +-- +-- > quoted-pair = ("\" (VCHAR / WSP)) / obs-qp +-- +-- @since 0.1.0.0 +quotedPair :: Char -> Bool +quotedPair c = vchar c || wsp c + +-- | Obsolete characters that can be escaped with a backslash. +-- +-- > obs-qp = "\" (%d0 / obs-NO-WS-CTL / LF / CR) +-- +-- @since 0.1.0.0 +quotedPairObs :: Char -> Bool +quotedPairObs c = + obsNoWsCtl c + || c == '\r' + || c == '\n' + || c == '\0' diff --git a/src/Addy/Internal/Parser.hs b/src/Addy/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Addy/Internal/Parser.hs @@ -0,0 +1,543 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +-- +-- Internal parsing functions. +module Addy.Internal.Parser + ( Mode (..), + Atom (..), + parse, + parseWithMode, + nameAddr, + addrSpec, + localPartP, + domainP, + displayNameP, + word, + atom, + dotAtom, + dotAtomLh, + dotAtomRh, + quoted, + quotedLh, + cfws, + ) +where + +import Addy.Internal.Char +import Addy.Internal.Types +import Addy.Internal.Validation +import Data.Attoparsec.Text (()) +import qualified Data.Attoparsec.Text as Atto +import Data.Foldable +import qualified Data.Text as Text +import qualified Net.IP as IP +import qualified Net.IPv4 as IP4 +import qualified Net.IPv6 as IP6 +import qualified Validation + +-- | Parsing mode. +-- +-- @since 0.1.0.0 +data Mode + = -- | Only support non-obsoleted addresses. + Strict + | -- | Include support for obsolete addresses. + Lenient + deriving (Eq, Show) + +-- | RFC 5322 @atom@. +-- +-- @since 0.1.0.0 +data Atom = Atom (Maybe CommentContent) Text (Maybe CommentContent) + deriving (Show) + +instance Semigroup Atom where + (<>) (Atom x0 y0 z0) (Atom x1 y1 z1) = + Atom (x0 <> x1) (y0 <> y1) (z0 <> z1) + +instance Monoid Atom where + mempty = Atom Nothing mempty Nothing + +-- | FIXME: Write description for atomJoin +-- +-- @since 0.1.0.0 +atomJoin :: Foldable t => Char -> t Atom -> Atom +atomJoin sep as + | null as = mempty + | otherwise = foldr1 go as + where + go :: Atom -> Atom -> Atom + go (Atom c0 t0 c1) (Atom c2 t1 c3) = + Atom (go' c0 c2) (t0 <> one sep <> t1) (go' c1 c3) + go' :: Maybe CommentContent -> Maybe CommentContent -> Maybe CommentContent + go' (Just x) (Just y) = Just (x <> CC (one ' ') <> y) + go' x y = x <|> y + +-- | An email address parser. +-- +-- @since 0.1.0.0 +parse :: Mode -> Atto.Parser EmailAddr +parse m = cleanComments <$> (nameAddr m <|> addrSpec m) + where + -- Since white space is allowed all over the place, filter out + -- comments that are just white space. + cleanComments :: EmailAddr -> EmailAddr + cleanComments addr@EmailAddr {_comments} = + addr + { _comments = + filter + ( \(Comment _ (CC t)) -> not $ Text.null (Text.strip t) + ) + _comments + } + +-- | Run the parser and then validate the resulting address. +-- +-- @since 0.1.0.0 +parseWithMode :: Mode -> Text -> Either (NonEmpty Error) EmailAddr +parseWithMode mode text = do + addr <- + first (toText >>> ParserFailedError >>> one) $ + Atto.parseOnly + ( parse mode <* (Atto.endOfInput "unparsed input") + ) + text + case validateEmailAddr addr of + Validation.Success ea -> Right ea + Validation.Failure es -> Left es + +-- | Parse email addresses in the @name-addr@ format. +-- +-- @since 0.1.0.0 +nameAddr :: Mode -> Atto.Parser EmailAddr +nameAddr mode = do + dp <- optional (displayNameP mode) + c0 <- optional (cfws mode) + _ <- Atto.char '<' + (c1, lp) <- localPartP mode <* Atto.char '@' + (dn, c2) <- domainP mode + _ <- Atto.char '>' + c3 <- optional (cfws mode) + let (dpc0, dpt, dpc1) = case dp of + Nothing -> (Nothing, Nothing, Nothing) + Just (Atom x y z) -> (x, Just (DP y), z) + pure $ + EmailAddr + { _displayName = dpt, + _localPart = lp, + _domain = dn, + _comments = + catMaybes + [ Comment BeforeDisplayName <$> dpc0, + Comment AfterDisplayName <$> dpc1, + Comment AfterDisplayName <$> c0, + Comment BeforeLocalPart <$> c1, + Comment AfterDomain <$> c2, + Comment AfterAddress <$> c3 + ] + } + +-- | Parse email addresses in the @addr-spec@ format. +-- +-- @since 0.1.0.0 +addrSpec :: Mode -> Atto.Parser EmailAddr +addrSpec mode = do + (c0, lp) <- localPartP mode <* Atto.char '@' + (dn, c1) <- domainP mode + pure $ + EmailAddr + { _displayName = Nothing, + _localPart = lp, + _domain = dn, + _comments = + catMaybes + [ Comment BeforeLocalPart <$> c0, + Comment AfterDomain <$> c1 + ] + } + +-- | Parse the @local-part@ of an email address. +-- +-- RFC 5322 §3.4.1 +-- +-- > local-part = dot-atom / quoted-string / obs-local-part +-- +-- @since 0.1.0.0 +localPartP :: Mode -> Atto.Parser (Maybe CommentContent, LocalPart) +localPartP mode = go "local part" + where + go = + case mode of + Strict -> do + Atom c0 t c1 <- (dotAtomLh <* thenAt) <|> (quotedLh <* thenAt) + pure (c0 <> c1, LP t) + Lenient -> do + -- Obsolete comes before quoted since the obsolete syntax allows + -- multiple quoted strings separated by dots. + Atom c0 t c1 <- + Atto.choice + [ dotAtom mode <* thenAt, + obsLocalPart <* thenAt, + quoted mode <* thenAt + ] + pure (c0 <> c1, LP t) + -- > obs-local-part = word *("." word) + obsLocalPart :: Atto.Parser Atom + obsLocalPart = do + t0 <- word mode + ts <- many (Atto.char '.' *> word mode) + pure (atomJoin '.' (t0 : ts)) + thenAt :: Atto.Parser () + thenAt = + Atto.peekChar' + >>= bool empty pass . (== '@') + +-- | Domain name parser. +-- +-- @since 0.1.0.0 +domainP :: Mode -> Atto.Parser (Domain, Maybe CommentContent) +domainP mode = go "domain name" + where + go = + case mode of + Strict -> + domainNameP + <|> domainLiteralP (fws mode $> CC (one ' ')) + Lenient -> + obsDomainP + <|> domainNameP + <|> domainLiteralP (cfws mode) + domainNameP :: Atto.Parser (Domain, Maybe CommentContent) + domainNameP = do + Atom c0 t c1 <- dotAtomRh + pure (Domain $ DN t, c0 <> c1) + -- > domain-literal = [CFWS] "[" *([FWS] dtext) [FWS] "]" [CFWS] + domainLiteralP :: + Atto.Parser CommentContent -> + Atto.Parser (Domain, Maybe CommentContent) + domainLiteralP lh = do + c0 <- optional lh + t <- addressLiteral mode + c1 <- optional (cfws mode) + pure (DomainLiteral t, c0 <> c1) + -- > obs-domain = atom *("." atom) + obsDomainP :: Atto.Parser (Domain, Maybe CommentContent) + obsDomainP = do + t0 <- atom mode + ts <- many (Atto.char '.' *> atom mode) + let Atom c0 t c1 = atomJoin '.' (t0 : ts) + pure (Domain $ DN t, c0 <> c1) + +-- | Parse a display name. +-- +-- @since 0.1.0.0 +displayNameP :: Mode -> Atto.Parser Atom +displayNameP mode = + case mode of + Strict -> phrase + Lenient -> phrase <|> obsPhrase + where + phrase = ( "display name") $ do + -- Always strict since in lenient mode we'll fall back to + -- obsolete mode anyways. + w0 <- word Strict + ws <- many (word Strict) + pure (atomJoin ' ' (w0 : ws)) + obsPhrase = ( "obsolete display name") $ do + w0 <- word mode + ws <- + many + ( word mode + <|> Atom Nothing <$> (Atto.char '.' <&> one) <*> pure Nothing + <|> Atom <$> (cfws mode <&> Just) <*> pure mempty <*> pure Nothing + ) + pure (atomJoin ' ' (w0 : ws)) + +-- | An atom or quoted string. +-- +-- > word = atom / quoted-string +-- +-- @since 0.1.0.0 +word :: Mode -> Atto.Parser Atom +word mode = atom mode <|> quoted mode + +-- | Parse an unquoted atom. +-- +-- > atom = [CFWS] 1*atext [CFWS] +-- +-- @since 0.1.0.0 +atom :: Mode -> Atto.Parser Atom +atom mode = + Atom + <$> optional (cfws mode) + <*> atextP + <*> optional (cfws mode) + +-- | Parse an unquoted atom that is allowed to contain periods. +-- +-- @since 0.1.0.0 +dotAtom' :: + Atto.Parser CommentContent -> + Atto.Parser CommentContent -> + Atto.Parser Atom +dotAtom' lh rh = do + c0 <- optional lh + t0 <- atextP + ts <- many (Atto.char '.' *> atextP) + c1 <- optional rh + pure (Atom c0 (Text.intercalate "." (t0 : ts)) c1) + +-- | RFC 5322 @dot-atom@. +-- +-- @since 0.1.0.0 +dotAtom :: Mode -> Atto.Parser Atom +dotAtom mode = dotAtom' (cfws mode) (cfws mode) + +-- | Strict @dot-atom-lh@ from RFC 5322 errata. +-- +-- > dot-atom-lh = [CFWS] dot-atom-text [FWS] +-- +-- @since 0.1.0.0 +dotAtomLh :: Atto.Parser Atom +dotAtomLh = + dotAtom' + (cfws Strict) + (CC <$> (fws Strict $> one ' ')) + +-- | Strict @dot-atom-rh@ from RFC 5322 errata. +-- +-- > dot-atom-rh = [FWS] dot-atom-text [CFWS] +-- +-- @since 0.1.0.0 +dotAtomRh :: Atto.Parser Atom +dotAtomRh = + dotAtom' + (CC <$> (fws Strict $> one ' ')) + (cfws Strict) + +-- | Is a character allowed in an atom? +-- +-- RFC 5322 §3.2.3 +-- +-- @since 0.1.0.0 +atextP :: Atto.Parser Text +atextP = Atto.takeWhile1 atext + +-- | A quoted string. +-- +-- RFC5322 §3.2.4 +-- +-- > qtext = %d33 / ; Printable US-ASCII +-- > %d35-91 / ; characters not including +-- > %d93-126 / ; "\" or the quote character +-- > obs-qtext +-- > +-- > qcontent = qtext / quoted-pair +-- > +-- > quoted-string = [CFWS] +-- > DQUOTE *([FWS] qcontent) [FWS] DQUOTE +-- > [CFWS] +-- > +-- > obs-qtext = obs-NO-WS-CTL +-- > +-- +-- RFC 6532 §3.2 +-- +-- > qtext =/ UTF8-non-ascii +-- +-- RFC 5322 errata item 3135 +-- +-- +-- > quoted-string = [CFWS] +-- > DQUOTE ((1*([FWS] qcontent) [FWS]) / FWS) DQUOTE +-- > [CFWS] +-- +-- This is the rule we use since it's consistent with the text of the RFC. +-- +-- @since 0.1.0.0 +quoted :: Mode -> Atto.Parser Atom +quoted mode = quoted' (cfws mode) (cfws mode) mode + +-- | General-purpose quoted-string parser. +-- +-- @since 0.1.0.0 +quoted' :: + Atto.Parser CommentContent -> + Atto.Parser CommentContent -> + Mode -> + Atto.Parser Atom +quoted' lh rh mode = ( "quoted content") $ do + c0 <- optional lh + _ <- Atto.char '"' + t <- Atto.many1 ((<>) <$> fws' <*> qcontent) + w <- fws' + _ <- Atto.char '"' + c1 <- optional rh + pure (Atom c0 (mconcat t <> w) c1) + where + -- Characters that are allowed in the quotes: + qcontent :: Atto.Parser Text + qcontent = qtextP <|> quotedPairP mode + qtextP :: Atto.Parser Text + qtextP = case mode of + Strict -> Atto.takeWhile1 qtext + Lenient -> + Atto.takeWhile1 (\c -> qtext c || qtextObs c) + <&> Text.filter (not . qtextObs) + fws' = (fws mode $> one ' ') <|> pure mempty + +-- | Strict @quoted-string-lh@ from RFC 5322 errata. +-- +-- @since 0.1.0.0 +quotedLh :: Atto.Parser Atom +quotedLh = + quoted' + (cfws Strict) + (CC <$> (fws Strict $> one ' ')) + Strict + +-- | Parse backslash escapes: +-- +-- @since 0.1.0.0 +quotedPairP :: Mode -> Atto.Parser Text +quotedPairP mode = go "quoted char" + where + go = Atto.char '\\' *> allowed + allowed = case mode of + Strict -> + Atto.satisfy quotedPair + <&> one + Lenient -> + Atto.satisfy (\c -> quotedPair c || quotedPairObs c) + <&> (one >>> Text.filter (not . quotedPairObs)) + +-- | Comments and folding white space. +-- +-- > ctext = %d33-39 / ; Printable US-ASCII +-- > %d42-91 / ; characters not including +-- > %d93-126 / ; "(", ")", or "\" +-- > obs-ctext +-- > +-- > obs-ctext = obs-NO-WS-CTL +-- > +-- > ccontent = ctext / quoted-pair / comment +-- > +-- > comment = "(" *([FWS] ccontent) [FWS] ")" +-- > +-- > CFWS = (1*([FWS] comment) [FWS]) / FWS +-- +-- @since 0.1.0.0 +cfws :: Mode -> Atto.Parser CommentContent +cfws mode = + ( "comment or space") + (cfws' <|> (CC <$> fws mode)) + where + cfws' :: Atto.Parser CommentContent + cfws' = do + cs <- Atto.many1 (fws' *> comment) <* fws' + pure (CC $ mconcat cs) + comment :: Atto.Parser Text + comment = do + _ <- Atto.char '(' + ts <- many (fws' *> (mconcat <$> Atto.many1 ccontent)) <* fws' + _ <- Atto.char ')' + pure (Text.intercalate " " ts) + ccontent :: Atto.Parser Text + ccontent = ctextP <|> quotedPairP mode <|> comment + ctextP :: Atto.Parser Text + ctextP = case mode of + Strict -> + Atto.takeWhile1 ctext + Lenient -> + Atto.takeWhile1 (\c -> ctext c || ctextObs c) + <&> Text.filter (not . ctextObs) + fws' :: Atto.Parser () + fws' = void (optional (fws mode)) + +-- | Folding white space. +-- +-- > FWS = ([*WSP CRLF] 1*WSP) / obs-FWS +-- > ; Folding white space +-- > +-- > obs-FWS = 1*WSP *(CRLF 1*WSP) +-- +-- @since 0.1.0.0 +fws :: Mode -> Atto.Parser Text +fws = \case + Strict -> do + w0 <- (Atto.takeWhile wsp <* crlf) <|> pure Text.empty + w1 <- Atto.takeWhile1 wsp + pure (w0 <> w1) + Lenient -> do + w0 <- Atto.takeWhile1 wsp + ws <- many (crlf *> Atto.takeWhile1 wsp) + pure (w0 <> mconcat ws) + where + crlf = Atto.string "\r\n" + +-- | Parse a domain/address literal. +-- +-- > dtext = %d33-90 / ; Printable US-ASCII +-- > %d94-126 / ; characters not including +-- > obs-dtext ; "[", "]", or "\" +-- > obs-dtext = obs-NO-WS-CTL / quoted-pair +-- +-- @since 0.1.0.0 +addressLiteral :: Mode -> Atto.Parser AddressLiteral +addressLiteral mode = + ( "address literal") + $ Atto.choice + $ map + wrap + [ IpAddressLiteral . IP.fromIPv6 <$> (Atto.string "IPv6:" *> IP6.parser), + TaggedAddressLiteral <$> tag <*> (Atto.char ':' *> lit), + IpAddressLiteral . IP.fromIPv4 <$> IP4.parser, + AddressLiteral <$> lit + ] + where + wrap :: Atto.Parser a -> Atto.Parser a + wrap p = + Atto.char '[' + *> p + <* optional (fws mode) + <* Atto.char ']' + tag :: Atto.Parser AddressTag + tag = Atto.takeWhile1 (\c -> c /= ':' && dtext c) <&> AT + lit :: Atto.Parser Literal + lit = + Lit . mconcat + <$> many + ( do + f0 <- fws' + ts <- dtextP + f1 <- fws' + pure (f0 <> ts <> f1) + ) + dtextP :: Atto.Parser Text + dtextP = + case mode of + Strict -> + Atto.takeWhile1 dtext + Lenient -> + -- Allow obsolete syntax, but don't capture it. + mconcat + <$> Atto.many1 + ( ( Atto.takeWhile1 (\c -> dtext c || obsNoWsCtl c) + <&> Text.filter (not . obsNoWsCtl) + ) + <|> (quotedPairP mode $> one '-') + ) + fws' :: Atto.Parser Text + fws' = fws mode $> one ' ' <|> pure mempty diff --git a/src/Addy/Internal/Render.hs b/src/Addy/Internal/Render.hs new file mode 100644 --- /dev/null +++ b/src/Addy/Internal/Render.hs @@ -0,0 +1,187 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +-- +-- Internal functions to render an 'EmailAddr' to a 'TB.Builder'. +module Addy.Internal.Render + ( Mode (..), + render, + renderToText, + renderAddrSpec, + renderDisplayName, + renderComments, + ) +where + +import Addy.Internal.Char +import Addy.Internal.Types +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as TB +import qualified Net.IP as IP +import Text.Show (Show (..), showParen, showString) +import Prelude hiding (show) + +-- | Render mode. +-- +-- @since 0.1.0.0 +data Mode + = -- | Render the entire email address, including the optional + -- display name and comments. + Full + | -- | Only render the simplest form of the email address. Only the + -- 'LocalPart' and 'Domain' are rendered in this mode. + Short + +-- | Render an email address. +-- +-- @since 0.1.0.0 +render :: Mode -> EmailAddr -> TB.Builder +render = \case + Short -> + renderAddrSpec Short + Full -> \addr@EmailAddr {..} -> + case _displayName of + Nothing -> + renderAddrSpec Full addr + <> renderComments Full AfterAddress _comments + Just name -> + mconcat + [ renderComments Full BeforeDisplayName _comments, + renderDisplayName name <> TB.singleton ' ', + renderComments Full AfterDisplayName _comments, + TB.singleton '<' <> renderAddrSpec Full addr <> TB.singleton '>', + renderComments Full AfterAddress _comments + ] + +-- | Render an email address in @addr-spec@ format. +-- +-- @since 0.1.0.0 +renderAddrSpec :: Mode -> EmailAddr -> TB.Builder +renderAddrSpec mode EmailAddr {..} = + mconcat + [ renderComments mode BeforeLocalPart _comments, + lp _localPart <> TB.singleton '@' <> dn _domain, + renderComments mode AfterDomain _comments + ] + where + lp :: LocalPart -> TB.Builder + lp (LP t) + | mustQuoteLocalPart t = wrap '"' '"' t + | otherwise = TB.fromText t + dn :: Domain -> TB.Builder + dn = \case + Domain (DN t) -> + TB.fromText t + DomainLiteral lit -> + wrap '[' ']' $ case lit of + IpAddressLiteral ip -> + if IP.isIPv6 ip + then "IPv6:" <> IP.encode ip + else IP.encode ip + TaggedAddressLiteral (AT tag) (Lit body) -> + tag <> ":" <> body + AddressLiteral (Lit body) -> + body + +-- | Render a display name. +-- +-- @since 0.1.0.0 +renderDisplayName :: DisplayName -> TB.Builder +renderDisplayName (DP t) + | Text.all (\c -> atext c || wsp c) t = + TB.fromText t + | otherwise = + wrap '"' '"' t + +-- | Render comments that have the given 'CommentLoc'. The comment +-- location is also used to decide where to introduce white space. +-- +-- @since 0.1.0.0 +renderComments :: Mode -> CommentLoc -> [Comment] -> TB.Builder +renderComments Short _ _ = mempty +renderComments Full loc cs = + case go (== loc) cs of + Nothing -> mempty + Just tb -> case loc of + BeforeDisplayName -> TB.singleton ' ' <> tb + AfterDisplayName -> tb <> TB.singleton ' ' + BeforeLocalPart -> tb <> TB.singleton ' ' + AfterDomain -> TB.singleton ' ' <> tb + AfterAddress -> TB.singleton ' ' <> tb + where + go :: (CommentLoc -> Bool) -> [Comment] -> Maybe TB.Builder + go f cs = + filter (\(Comment loc (CC t)) -> f loc && not (Text.null t)) cs + & map (\(Comment _ (CC t)) -> t) + & Text.intercalate " " + & \t -> + if Text.null t + then Nothing + else Just $ wrap '(' ')' t + +-- | Render the given address as text. +-- +-- @since 0.1.0.0 +renderToText :: Mode -> EmailAddr -> Text +renderToText m = + render m + >>> TB.toLazyText + >>> toStrict + +-- | Wrap and quote some text. +-- +-- @since 0.1.0.0 +wrap :: Char -> Char -> Text -> TB.Builder +wrap lh rh t = + mconcat + [ TB.singleton lh, + Text.foldl' escape mempty t, + TB.singleton rh + ] + where + escape :: TB.Builder -> Char -> TB.Builder + escape tb c + | c == lh || c == rh || c == '\\' = + tb <> TB.singleton '\\' <> TB.singleton c + | otherwise = + tb <> TB.singleton c + +-- | 'True' if the give text, when used as the @local-part@ of an +-- email address must be wrapped in quotation marks. +-- +-- @since 0.1.0.0 +mustQuoteLocalPart :: Text -> Bool +mustQuoteLocalPart name = + Text.any + ( \c -> + c == '"' + || c == '\\' + || c == ')' + || c == '(' + || c == '@' + || wsp c + ) + name + || Text.isPrefixOf "." name + || Text.isSuffixOf "." name + || Text.isInfixOf ".." name + || Text.null name -- Yes, this is totally legit. + +-- Orphan instance that renders the email address. +instance Show EmailAddr where + showsPrec d addr = + showParen (d > 10) $ + showString "EmailAddr " . showsPrec d (render Full addr) diff --git a/src/Addy/Internal/Types.hs b/src/Addy/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Addy/Internal/Types.hs @@ -0,0 +1,370 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +-- +-- The module exports internal types along with their constructors. +-- +-- The rendering code relies on the newtype wrappers around 'Text' to +-- keep out invalid characters. Prefer to use the official interface +-- if possible. +module Addy.Internal.Types + ( Error (..), + EmailAddr (..), + displayName, + localPart, + domain, + comments, + DisplayName (..), + LocalPart (..), + Domain (..), + _Domain, + _DomainLiteral, + DomainName (..), + HostName (..), + _HostNames, + AddressLiteral (..), + _IpAddressLiteral, + _TaggedAddressLiteral, + _AddressLiteral, + AddressTag (..), + Literal (..), + Comment (..), + _Comment, + commentLoc, + commentContent, + CommentLoc (..), + CommentContent (..), + ) +where + +import Control.Lens (Iso', Lens', Prism', iso, lens, prism') +import qualified Data.Text as Text +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Net.IP (IP) +import Text.Show (Show (..), showParen, showString) + +-- | Potential validation errors. +-- +-- @since 0.1.0.0 +data Error + = -- | A component of an email address may not start with the + -- recorded prefix text. + InvalidPrefixError Text + | -- | A component of an email address may not end with the recorded + -- suffix text. + InvalidSuffixError Text + | -- | A component of an email address contains invalid characters. + InvalidCharactersError Text + | -- | A component of an email address does not meet the set length + -- requirements. The values in this constructor are @min@, @max@, + -- and @actual@. + InvalidLengthError Int Int Int + | -- | The input to the address decoder was not a valid email + -- address and produced the recorded error message. + ParserFailedError Text + deriving (Show, Eq) + +-- | The representation of a complete email address. +-- +-- The parser preserves optional components such as the display name +-- and comments. The rendering code can optionally include these +-- optional elements when turning the address back into 'Text'. +-- +-- @since 0.1.0.0 +data EmailAddr = EmailAddr + { _displayName :: Maybe DisplayName, + _localPart :: LocalPart, + _domain :: Domain, + _comments :: [Comment] + } + +-- | Optional display name. Addresses in the @name-addr@ format +-- from RFC 5322 allow descriptive text to precede the address. +-- This is commonly used in email messages to list the name of the +-- address' owner. +-- +-- @since 0.1.0.0 +displayName :: Lens' EmailAddr (Maybe DisplayName) +displayName = lens _displayName (\e d -> e {_displayName = d}) + +-- | The 'LocalPart' of an email address usually references the +-- destination mailbox on the 'Domain' server. However, the +-- content of the 'LocalPart' can only be understood by the +-- receiving 'Domain'. +-- +-- @since 0.1.0.0 +localPart :: Lens' EmailAddr LocalPart +localPart = lens _localPart (\e l -> e {_localPart = l}) + +-- | The 'Domain' refers to the fully-qualified domain name that +-- accepts mail for the associated 'LocalPart'. See the +-- documentation for the 'Domain' type for more details. +-- +-- @since 0.1.0.0 +domain :: Lens' EmailAddr Domain +domain = lens _domain (\e d -> e {_domain = d}) + +-- | Addresses in both the @name-addr@ and @addr-spec@ formats +-- support comments. +-- +-- @since 0.1.0.0 +comments :: Lens' EmailAddr [Comment] +comments = lens _comments (\e cs -> e {_comments = cs}) + +-- | Optional display name. Usually this is the name of the person +-- who receives email at the associated address. +-- +-- > Display Name +-- +-- @since 0.1.0.0 +newtype DisplayName = DP + { displayNameText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "DisplayName" Text + +-- | The name of the mailbox on the associated 'Domain'. +-- +-- @since 0.1.0.0 +newtype LocalPart = LP + { localPartText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "LocalPart" Text + +-- | A fully-qualified domain name /or/ an address literal. +-- +-- Most email addresses use a domain name. However, it's perfectly +-- legal to use an 'AddressLiteral' instead. +-- +-- @since 0.1.0.0 +data Domain + = Domain DomainName + | DomainLiteral AddressLiteral + deriving (Show, Eq) + +-- | Prism for working with domain names. +-- +-- @since 0.1.0.0 +_Domain :: Prism' Domain DomainName +_Domain = + prism' + Domain + ( \case + Domain dn -> Just dn + DomainLiteral {} -> Nothing + ) + +-- | Prism for working with domain literals. +-- +-- @since 0.1.0.0 +_DomainLiteral :: Prism' Domain AddressLiteral +_DomainLiteral = + prism' + DomainLiteral + ( \case + Domain {} -> Nothing + DomainLiteral dl -> Just dl + ) + +-- | A fully-qualified domain name which is made up of a list of +-- host names (labels) separated by dots. +-- +-- @since 0.1.0.0 +newtype DomainName = DN + { domainNameText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "DomainName" Text + +-- | The name of one host component of a domain name. +-- +-- @since 0.1.0.0 +newtype HostName = HN + { hostNameText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "HostName" Text + +-- | Iso for converting between domain names and a list of host names. +-- +-- >>> "gmail.uk.co" ^. _DomainName._HostNames & map (review _HostName) +-- ["gmail","uk","co"] +-- +-- @since 0.1.0.0 +_HostNames :: Iso' DomainName [HostName] +_HostNames = + iso + (domainNameText >>> Text.splitOn "." >>> map HN) + (map hostNameText >>> Text.intercalate "." >>> DN) + +-- | Address literals can be used instead of a domain name to direct +-- mail to a specific IP address or other tagged address type. +-- +-- Example email addresses with address literals: +-- +-- > example@[127.0.0.1] +-- > example@[IPv6:1111:2222:3333:4444:5555:6666:7777] +-- > example@[Just-some-text] +-- +-- @since 0.1.0.0 +data AddressLiteral + = -- | A literal IP address as defined in RFC 5321 §4.1.3. The + -- address can be in many formats so it is presented here in its + -- parsed form. + IpAddressLiteral IP + | -- | RFC 5321 also defines a /general address literal/ where a + -- /standardized tag/ precedes the address itself. The only + -- information provided about the standardized tag is: + -- + -- > Standardized-tag MUST be specified in a + -- > Standards-Track RFC and registered with IANA + TaggedAddressLiteral AddressTag Literal + | -- | RFC 5322 defines a @domain-literal@ as (roughly) a span of + -- characters that are allowed in a domain name. The + -- interpretation of those characters is left to \"separate + -- documents\" such as RFC 5321. + -- + -- If an address literal cannot be parsed in one of the proceeding + -- formats it is encoded as a 'Literal' value. + AddressLiteral Literal + deriving (Show, Eq) + +-- | Prism for working with IP address literals. +-- +-- @since 0.1.0.0 +_IpAddressLiteral :: Prism' AddressLiteral IP +_IpAddressLiteral = + prism' + IpAddressLiteral + ( \case + IpAddressLiteral ip -> Just ip + TaggedAddressLiteral {} -> Nothing + AddressLiteral {} -> Nothing + ) + +-- | Prism for working with tagged address literals. +-- +-- @since 0.1.0.0 +_TaggedAddressLiteral :: Prism' AddressLiteral (AddressTag, Literal) +_TaggedAddressLiteral = + prism' + (uncurry TaggedAddressLiteral) + ( \case + IpAddressLiteral {} -> Nothing + TaggedAddressLiteral tag body -> Just (tag, body) + AddressLiteral {} -> Nothing + ) + +-- | Prism for working with address literals. +-- +-- @since 0.1.0.0 +_AddressLiteral :: Prism' AddressLiteral Literal +_AddressLiteral = + prism' + AddressLiteral + ( \case + IpAddressLiteral {} -> Nothing + TaggedAddressLiteral {} -> Nothing + AddressLiteral lit -> Just lit + ) + +-- | A tag that can be used with a 'TaggedAddressLiteral'. +-- +-- @since 0.1.0.0 +newtype AddressTag = AT + { addressTagText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "AddressTag" Text + +-- | A literal address that can be used with a 'TaggedAddressLiteral' +-- or 'AddressLiteral'. +-- +-- @since 0.1.0.0 +newtype Literal = Lit + { literalText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "Literal" Text + +-- | A comment which may appear in an email address in a specific +-- location. +-- +-- @since 0.1.0.0 +data Comment = Comment CommentLoc CommentContent + deriving (Show, Eq) + +-- | Prism for working with a 'Comment'. +-- +-- @since 0.1.0.0 +_Comment :: Prism' Comment (CommentLoc, CommentContent) +_Comment = + prism' + (uncurry Comment) + (\(Comment loc cc) -> Just (loc, cc)) + +-- | Lens for working with comment locations. +-- +-- @since 0.1.0.0 +commentLoc :: Lens' Comment CommentLoc +commentLoc = + lens + (\(Comment loc _) -> loc) + (\(Comment _ cc) loc -> Comment loc cc) + +-- | Lens for working with comment contents. +-- +-- @since 0.1.0.0 +commentContent :: Lens' Comment CommentContent +commentContent = + lens + (\(Comment _ cc) -> cc) + (\(Comment loc _) cc -> Comment loc cc) + +-- | The location where a comment was parsed or where it should be +-- rendered. +-- +-- @since 0.1.0.0 +data CommentLoc + = -- | Just before the 'DisplayName'. + BeforeDisplayName + | -- | Just after the 'DisplayName' but before the address. + AfterDisplayName + | -- | Before the 'LocalPart' of the address. + BeforeLocalPart + | -- | After the 'Domain'. + AfterDomain + | -- | After the complete address. + AfterAddress + deriving (Show, Eq) + +-- | Text that can appear in a comment. +-- +-- @since 0.1.0.0 +newtype CommentContent = CC + { commentContentText :: Text + } + deriving newtype (Eq, Semigroup) + deriving (Show) via RenamedShow "CommentContent" Text + +-- | Newtype wrapper for deriving 'Show' instances that lie about the +-- name of the constructor. +newtype RenamedShow (n :: Symbol) a = RS a + +instance (Show a, KnownSymbol n) => Show (RenamedShow n a) where + showsPrec d (RS x) = + showParen (d > 10) $ + showString (symbolVal (Proxy :: Proxy n) <> " ") + . showsPrec d x diff --git a/src/Addy/Internal/Validation.hs b/src/Addy/Internal/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Addy/Internal/Validation.hs @@ -0,0 +1,238 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +-- +-- Internal data validation functions. +module Addy.Internal.Validation + ( validateHostName, + validateDomainName, + validateLocalPart, + validateDisplayName, + validateLiteral, + validateAddressTag, + validateCommentContent, + validateEmailAddr, + ) +where + +import Addy.Internal.Char +import Addy.Internal.Types +import qualified Data.ByteString as ByteString +import qualified Data.Text as Text +import qualified Data.Text.ICU as ICU +import Validation + +-- | Validate a single host name. Each host name in a domain name +-- (referred to as a /label/) must validate with this function. +-- +-- RFC 2181 §11 clearly states that there are no restrictions placed +-- on which characters may appear in a label. However, due to legacy +-- issues we enforce the rule from RFC 952 §1 that disallows hyphens +-- as the first or last character of a label. +-- +-- RFC 5322 §3.4.1 restricts the characters that may appear in the +-- domain component of an /email address/. Even though a DNS label +-- does not impose such restrictions, in order to be a valid email +-- address the label must only be composed of so-called @atext@ +-- characters or @UTF8-non-ascii@ characters. +-- +-- Finally, RFC 2181 §11 restricts the length of a label to 63 bytes +-- and the fully-qualified domain name to 255 bytes. RFC 6532 which +-- extends the email syntax to allow UTF-8 encoded Unicode characters +-- briefly states in §3.4 to continue using bytes, and not +-- characters. It also states that Unicode text should be normalized +-- (which we do). +-- +-- @since 0.1.0.0 +validateHostName :: Text -> Validation (NonEmpty Error) HostName +validateHostName content = + let content' = Text.toLower (ICU.normalize ICU.NFC content) + in HN content' + <$ ( validateNotPrefix "-" content' + *> validateNotSuffix "-" content' + *> validateAllowedChars atext content' + *> validateLength 1 63 content' + ) + +-- | Validate a domain name. +-- +-- The domain name is split into host names (labels) and each label is +-- validated with 'validateHostName'. +-- +-- @since 0.1.0.0 +validateDomainName :: Text -> Validation (NonEmpty Error) DomainName +validateDomainName name = + fromHostList <$> (validateLength 1 255 name *> validHostList) + where + validHostList :: Validation (NonEmpty Error) [HostName] + validHostList = + foldr + ( \h hs -> (:) <$> validateHostName h <*> hs + ) + (pure []) + (Text.splitOn "." name) + fromHostList :: [HostName] -> DomainName + fromHostList hs = + map coerce hs + & Text.intercalate "." + & DN + +-- | Validate and normalize the text content of the 'LocalPart' of an +-- email address. +-- +-- RFC 3696 §3 restricts the length of the local part to a maximum of +-- 64 bytes. RFC 6532 extends the character set to include Unicode +-- characters but maintains the length measurement as bytes and not +-- characters. +-- +-- @since 0.1.0.0 +validateLocalPart :: + Text -> Validation (NonEmpty Error) LocalPart +validateLocalPart content = + let content' = ICU.normalize ICU.NFC content + in LP content' + <$ ( validateLength 1 64 content' + *> validateAllowedChars allowedChar content' + ) + where + allowedChar :: Char -> Bool + allowedChar c = atext c || c == '.' || qtext c || quotedPair c + +-- | Validate the content of a 'DisplayName'. +-- +-- There does not appear to be a limit on the length of the display +-- name. For consistency and efficiency we limit it to 64 bytes, the +-- same as the local part. +-- +-- @since 0.1.0.0 +validateDisplayName :: Text -> Validation (NonEmpty Error) DisplayName +validateDisplayName content = + DP content + <$ ( validateLength 1 64 content + *> validateAllowedChars allowedChar content + ) + where + allowedChar :: Char -> Bool + allowedChar c = atext c || qtext c || quotedPair c + +-- | Validate the 'Literal' content of a domain literal. +-- +-- There does not appear to be a limit on the length of an address +-- literal but for consistency with DNS labels we limit them to 63 +-- bytes. +-- +-- @since 0.1.0.0 +validateLiteral :: Text -> Validation (NonEmpty Error) Literal +validateLiteral content = + Lit content + <$ ( validateLength 1 63 content + *> validateAllowedChars allowedChar content + ) + where + allowedChar :: Char -> Bool + allowedChar c = dtext c || wsp c || c == '\r' || c == '\n' + +-- | Validate the content of an 'AddressTag'. Uses the same rules as +-- 'validateLiteral'. +-- +-- @since 0.1.0.0 +validateAddressTag :: Text -> Validation (NonEmpty Error) AddressTag +validateAddressTag content = AT content <$ validateLiteral content + +-- | Validate the content of a comment. +-- +-- There does not appear to be a limit on the length of a comment. +-- For consistency and efficiency we limit it to 64 bytes, the same as +-- the local part. +-- +-- @since 0.1.0.0 +validateCommentContent :: Text -> Validation (NonEmpty Error) CommentContent +validateCommentContent content = + CC content + <$ ( validateLength 1 64 content + *> validateAllowedChars allowedChar content + ) + where + allowedChar :: Char -> Bool + allowedChar c = ctext c || quotedPair c + +-- | Validate an entire 'EmailAddr'. This is used by the parser to +-- validate rules that are not encoded in the various component parsers. +-- +-- @since 0.1.0.0 +validateEmailAddr :: EmailAddr -> Validation (NonEmpty Error) EmailAddr +validateEmailAddr EmailAddr {..} = + EmailAddr + <$> displayNameV + <*> validateLocalPart (localPartText _localPart) + <*> domainV + <*> commentsV + where + displayNameV :: Validation (NonEmpty Error) (Maybe DisplayName) + displayNameV = case _displayName of + Nothing -> pure Nothing + Just (DP t) -> Just <$> validateDisplayName t + domainV :: Validation (NonEmpty Error) Domain + domainV = case _domain of + Domain (DN t) -> Domain <$> validateDomainName t + DomainLiteral lit -> DomainLiteral <$> addrLiteralV lit + addrLiteralV :: AddressLiteral -> Validation (NonEmpty Error) AddressLiteral + addrLiteralV = \case + IpAddressLiteral ip -> + pure (IpAddressLiteral ip) + TaggedAddressLiteral (AT at) (Lit lit) -> + TaggedAddressLiteral <$> validateAddressTag at <*> validateLiteral lit + AddressLiteral (Lit t) -> + AddressLiteral <$> validateLiteral t + commentsV :: Validation (NonEmpty Error) [Comment] + commentsV = + foldr + ( \(Comment loc (CC t)) cs -> + (:) . Comment loc <$> validateCommentContent t <*> cs + ) + (pure []) + _comments + +-- | Validate that the given text does not begin with the given prefix. +-- +-- @since 0.1.0.0 +validateNotPrefix :: Text -> Text -> Validation (NonEmpty Error) () +validateNotPrefix prefix name = + failureIf (Text.isPrefixOf prefix name) (InvalidPrefixError prefix) + +-- | Validate that the given text does not end with the given suffix. +-- +-- @since 0.1.0.0 +validateNotSuffix :: Text -> Text -> Validation (NonEmpty Error) () +validateNotSuffix suffix name = + failureIf (Text.isSuffixOf suffix name) (InvalidSuffixError suffix) + +-- | Validate that the text only contains characters for which the +-- given function returns true. +-- +-- @since 0.1.0.0 +validateAllowedChars :: (Char -> Bool) -> Text -> Validation (NonEmpty Error) () +validateAllowedChars f t = + failureUnless (Text.all f t) (InvalidCharactersError $ Text.filter (not . f) t) + +-- | Validate the length of the given text falls within the given +-- @min@ and @max@ values. +-- +-- @since 0.1.0.0 +validateLength :: Int -> Int -> Text -> Validation (NonEmpty Error) () +validateLength minL maxL t = + let bytes = ByteString.length (encodeUtf8 t) + in failureIf + (bytes < minL || bytes > maxL) + (InvalidLengthError minL maxL bytes) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,32 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +module Main + ( main, + ) +where + +import qualified ParserTest +import qualified RenderTest +import Test.Tasty + +-- | Main. +main :: IO () +main = + defaultMain $ + testGroup + "Email" + [ ParserTest.test, + RenderTest.test + ] diff --git a/test/ParserTest.hs b/test/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/ParserTest.hs @@ -0,0 +1,129 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +module ParserTest + ( test, + ) +where + +import Addy.Internal.Parser as P +import Addy.Internal.Render () +import Addy.Internal.Types +import qualified Hedgehog +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog +import TestData + +test :: TestTree +test = + testGroup + "Parser" + [ testCase "isemail tests" testParserWithIsEmail, + testCase "RFC 5322 examples" testRfc5322Examples, + testCase "Wikipedia internationalization examples" testWikipediaIntExamples, + testCase "Miscellaneous examples" testMiscExamples, + testProperty + "Generated short addresses" + (testGeneratedExamples genShortEmail), + testProperty + "Generated long addresses" + (testGeneratedExamples genLongEmail) + ] + +testRfc5322Examples :: Assertion +testRfc5322Examples = do + mapM_ (fst >>> go) rfc5322Examples + -- Only works in lenient mode: + mapM_ (\(a, _, _) -> assertParse Lenient a) rfc5322ObsExamples + where + go :: Text -> Assertion + go t = do + assertParse Strict t + assertParse Lenient t + +testWikipediaIntExamples :: Assertion +testWikipediaIntExamples = + mapM_ go wikipediaIntExamples + where + go t = do + assertParse Strict t + assertParse Lenient t + +testMiscExamples :: Assertion +testMiscExamples = + forM_ examples $ \t -> do + assertParse Strict t + assertParse Lenient t + where + examples = + miscExamples + <> [ "(((((((((())))))))))user@example.org" + ] + +testGeneratedExamples :: Hedgehog.Gen Text -> Hedgehog.Property +testGeneratedExamples gen = + Hedgehog.property $ do + source <- Hedgehog.forAll gen + let result = runParse source + Hedgehog.annotateShow result + Hedgehog.assert (isRight result) + where + runParse = parseWithMode Strict + +assertParse :: Mode -> Text -> Assertion +assertParse mode text = + let r = parseWithMode mode text + in assertBool + (toString text <> " " <> show r <> " " <> show mode) + (isRight r) + +testParserWithIsEmail :: Assertion +testParserWithIsEmail = mapM_ go =<< isEmailTests + where + go :: (IsEmailTest, IsEmailCat) -> Assertion + go (isemail, cat) = case cat of + CatError -> do + shouldFail Strict isemail + shouldFail Lenient isemail + CatDeprec -> do + shouldFail Strict isemail + shouldPass Lenient isemail + CatOkay -> + shouldPass Strict isemail + shouldPass, shouldFail :: Mode -> IsEmailTest -> Assertion + shouldPass = expect isRight + shouldFail = expect isLeft + expect :: + (Either (NonEmpty Error) EmailAddr -> Bool) -> + Mode -> + IsEmailTest -> + Assertion + expect f mode ie = + let result = runParse mode ie + in assertBool (report mode ie result) (f result) + runParse :: Mode -> IsEmailTest -> Either (NonEmpty Error) EmailAddr + runParse mode = parseWithMode mode . ietAddr + report :: Mode -> IsEmailTest -> Either (NonEmpty Error) EmailAddr -> String + report mode isemail result = + mconcat + [ "IsEmail test id ", + show (ietId isemail), + " in mode: ", + show mode, + " did not expect: ", + show result, + " from: ", + toString (ietAddr isemail) + ] diff --git a/test/README.md b/test/README.md new file mode 100644 --- /dev/null +++ b/test/README.md @@ -0,0 +1,6 @@ +Test Data +========= + +Test data was taken from the [isemail][] project. + +[isemail]: https://github.com/dominicsayers/isemail diff --git a/test/RenderTest.hs b/test/RenderTest.hs new file mode 100644 --- /dev/null +++ b/test/RenderTest.hs @@ -0,0 +1,156 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +module RenderTest + ( test, + ) +where + +import qualified Addy.Internal.Parser as Parser +import Addy.Internal.Render +import Addy.Internal.Types +import Data.Char +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as TB +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import TestData + +test :: TestTree +test = + testGroup + "Render" + [ testCase "isemail tests" testFromisEmailTests, + testCase "RFC 5322 examples" testRfcExamples, + testCase "Obsolete examples" testObsExamples, + testCase "Oddities" testOddities, + testCase "Wikipedia" testWikipediaExamples, + testCase "Misc" testMiscExamples + ] + +testRfcExamples :: Assertion +testRfcExamples = + mapM_ go rfc5322Examples + where + go :: (Text, Text) -> Assertion + go (source, expectS) = do + (_, actualS, actualF) <- roundTrip Parser.Strict source + let expectF = + -- We don't render the brackets unless they are needed. + if Text.isPrefixOf "<" source + && Text.isSuffixOf ">" source + then Text.drop 1 (Text.dropEnd 1 source) + else source + actualS @?= expectS + actualF @?= expectF + idempotentTest actualS actualF + +testObsExamples :: Assertion +testObsExamples = + mapM_ go rfc5322ObsExamples + where + go :: (Text, Text, Text) -> Assertion + go (source, simple, full) = do + (_, actualS, actualF) <- roundTrip Parser.Lenient source + actualS @?= simple + actualF @?= full + idempotentTest actualS actualF + +-- | Weird stuff that we'll parse but won't render. +testOddities :: Assertion +testOddities = + mapM_ + go + [ ( "(some (ne(st)ed) comment) example@example.com", + "(some nested comment) example@example.com", + "example@example.com" + ) + ] + where + go :: (Text, Text, Text) -> Assertion + go (source, full, simple) = do + (_, actualS, actualF) <- roundTrip Parser.Strict source + actualS @?= simple + actualF @?= full + +testMiscExamples :: Assertion +testMiscExamples = + forM_ miscExamples $ \source -> do + (_, actualS, actualF) <- roundTrip Parser.Strict source + actualS @?= source + actualF @?= source + +testFromisEmailTests :: Assertion +testFromisEmailTests = do + tests <- isEmailTests + mapM_ + go + ( filter + ( \(iet, cat) -> + cat == CatOkay + && ietId iet /= 42 -- Unnecessary quoting. + && ietId iet /= 45 -- Unnecessary quoting. + && ietId iet /= 55 -- Unnecessary quoting. + && ietId iet /= 60 -- Unnecessary quoting. + && ietId iet /= 79 -- We format better. + && ietId iet /= 81 -- We format better. + && ietId iet /= 85 -- We format better. + && ietId iet /= 88 -- We strip \r\n. + && ietId iet /= 92 -- We flattten comments. + && ietId iet /= 144 -- We strip \r\n. + && ietId iet /= 148 -- We strip \r\n. + && ietId iet /= 153 -- We strip \r\n. + ) + tests + ) + where + go :: (IsEmailTest, IsEmailCat) -> Assertion + go (iet, _) = do + (_, _, actualF) <- roundTrip Parser.Strict (ietAddr iet) + fixup actualF @?= fixup (ietAddr iet) + -- Ignore white space changes and revert IPv6 address formatting + fixup :: Text -> Text + fixup = Text.filter (not . isSpace) . Text.replace ":0:" "::" + +testWikipediaExamples :: Assertion +testWikipediaExamples = + mapM_ go wikipediaIntExamples + where + go :: Text -> Assertion + go source = do + (_, simple, full) <- roundTrip Parser.Strict source + simple @?= source + full @?= source + +roundTrip :: MonadFail m => Parser.Mode -> Text -> m (EmailAddr, Text, Text) +roundTrip pmode t = + case Parser.parseWithMode pmode t of + Left e -> fail (show t <> " " <> show e) + Right addr -> + pure + ( addr, + toStrict $ TB.toLazyText (render Short addr), + toStrict $ TB.toLazyText (render Full addr) + ) + +-- | Test that parsing the rendered output and then rendering it again +-- produces the same results. +idempotentTest :: Text -> Text -> Assertion +idempotentTest simple full = do + (_, x, y) <- roundTrip Parser.Strict simple + x @?= simple -- Parsing and rending a simple address should + y @?= simple -- produce a simple rendering both times. + (_, z, w) <- roundTrip Parser.Strict full + z @?= simple + w @?= full diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,235 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. It is subject to the license +-- terms in the LICENSE file found in the top-level directory of this +-- distribution and at: +-- +-- https://code.devalot.com/open/addy +-- +-- No part of this package, including this file, may be copied, +-- modified, propagated, or distributed except according to the terms +-- contained in the LICENSE file. +-- +-- License: BSD-2-Clause +module TestData + ( IsEmailTest (..), + IsEmailCat (..), + isEmailTests, + rfc5322Examples, + rfc5322ObsExamples, + wikipediaIntExamples, + miscExamples, + genShortEmail, + genLongEmail, + ) +where + +import Addy.Internal.Char (utf8NonAscii) +import Data.Aeson (FromJSON) +import qualified Data.Aeson as Aeson +import Data.Char +import qualified Data.Text as Text +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Network.HTTP.Types.URI (urlDecode) +import Test.Tasty.HUnit + +data IsEmailTest = IET + { ietId :: Int, + ietAddr :: Text, + ietCat :: Text, + ietDia :: Text + } + deriving stock (Generic, Show) + deriving anyclass (FromJSON) + +data IsEmailCat + = CatError + | CatDeprec + | CatOkay + deriving (Eq, Show) + +isEmailTests :: IO [(IsEmailTest, IsEmailCat)] +isEmailTests = do + let fileName = "test/isemail.json" + tests <- (Aeson.decode <$> readFileLBS fileName) >>= \case + Nothing -> assertFailure "failed to load the isemail.json file" + Just ts -> pure ts + pure $ map (\t -> (decodeAddr t, decodeCat t)) tests + +-- | The XSL file URL-encodes the email addresses. Additionally, the +-- XML file encodes some characters by adding 0x2400 to them. +decodeAddr :: IsEmailTest -> IsEmailTest +decodeAddr iet@IET {ietAddr} = + iet + { ietAddr = unCtrl (decode ietAddr) + } + where + decode :: Text -> Text + decode = decodeUtf8 . urlDecode False . encodeUtf8 + unCtrl :: Text -> Text + unCtrl = + let f c = + if c >= '\x2400' && c <= '\x241f' + then chr (ord c - 0x2400) + else c + in Text.map f + +decodeCat :: IsEmailTest -> IsEmailCat +decodeCat iet = go & override + where + go = case ietCat iet of + "ISEMAIL_ERR" -> CatError + "ISEMAIL_DEPREC" -> CatDeprec + _ -> CatOkay + override cat + -- We enforce character limits so these will fail. + | ietId iet == 26 = CatError + | ietId iet == 28 = CatError + | ietId iet == 41 = CatError + -- This is obviously wrong if you put even the slightest amount + -- of thought into it. + | ietId iet == 43 = CatError + -- This one is a bit silly. Even if that form is deprecated + -- it would then pass under the general @domain-literal@ rule + -- in RFC 5322 §3.4.1. + | ietId iet == 71 = CatOkay + -- RFC 5322 (and its errata) clearly allows whitespace before + -- and after the at sign. + | ietId iet == 85 = CatOkay + -- It's not worth supporting the very obsolete syntax of having + -- multiple empty lines before an email address. + | ietId iet == 89 = CatError + | ietId iet == 149 = CatError + -- These should be marked at deprecated. + | ietId iet == 115 = CatDeprec + | ietId iet == 116 = CatDeprec + | ietId iet == 117 = CatDeprec + -- Obsolete and won't pass validation because they only contain + -- obsolete characters! + | ietId iet == 124 = CatError + | ietId iet == 125 = CatError + | ietId iet == 134 = CatError + | ietId iet == 138 = CatError + | ietId iet == 139 = CatError + -- Nothing to override. + | otherwise = cat + +rfc5322Examples :: [(Text, Text)] +rfc5322Examples = + [ ("John Doe ", "jdoe@machine.example"), + ("Mary Smith ", "mary@example.net"), + ("Michael Jones ", "mjones@machine.example"), + ("\"Joe Q. Public\" ", "john.q.public@example.com"), + ("Mary Smith ", "mary@x.test"), + ("jdoe@example.org", "jdoe@example.org"), + ("Who? ", "one@y.test"), + ("", "boss@nil.test"), + ("\"Giant; \\\"Big\\\" Box\" ", "sysservices@example.net"), + ("Pete ", "pete@silly.example"), + ("Ed Jones ", "c@a.test"), + ("joe@where.test", "joe@where.test"), + ("John ", "jdoe@one.test"), + ("\"Mary Smith: Personal Account\" ", "smith@home.example"), + ("Jane Brown ", "j-brown@other.example"), + ("John (my dear friend)", "jdoe@one.test") + ] + +rfc5322ObsExamples :: [(Text, Text, Text)] +rfc5322ObsExamples = + [ ( "Pete(A nice \\) chap) ", + "pete@silly.test", + "Pete (A nice \\) chap) <(his account) pete@silly.test (his host)>" + ), + ( "Chris Jones ", + "c@public.example", + "Chris Jones " + ) + ] + +wikipediaIntExamples :: [Text] +wikipediaIntExamples = + [ "Pelé@example.com", + "δοκιμή@παράδειγμα.δοκιμή", + "我買@屋企.香港", + "二ノ宮@黒川.日本", + "медведь@с-балалайкой.рф", + "संपर्क@डाटामेल.भारत" + ] + +-- | Other examples that should pass. +-- +-- > (source, simple-format) +miscExamples :: [Text] +miscExamples = + [ "example+label@example.com", + "a@b", + "simple@example.com", + "very.common@example.com", + "disposable.style.email.with+symbol@example.com", + "other.email-with-hyphen@example.com", + "fully-qualified-domain@example.com", + "user.name+tag+sorting@example.com", + "x@example.com", + "example-indeed@strange-example.com", + "admin@mailserver1", + "example@s.example", + "\"john..doe\"@example.org", + "mailhost!username@example.org", + "user%example.com@example.org" + ] + +genLocalPart :: Gen Text +genLocalPart = + Gen.filter okay (Gen.text (Range.linear 1 30) unicode) + where + okay :: Text -> Bool + okay t = + Text.all allowedChar t + && not (Text.isPrefixOf "." t) + && not (Text.isSuffixOf "." t) + +genDomain :: Gen Text +genDomain = + Gen.filter okay (Gen.text (Range.linear 1 50) unicode) + where + okay :: Text -> Bool + okay t = + Text.all allowedChar t + && not (Text.isPrefixOf "-" t) + && not (Text.isSuffixOf "-" t) + +genShortEmail :: Gen Text +genShortEmail = do + localPart <- genLocalPart + domain <- genDomain + pure (localPart <> "@" <> domain) + +genLongEmail :: Gen Text +genLongEmail = do + display <- genLocalPart + localPart <- genLocalPart + domain <- genDomain + pure $ + mconcat + [ display, + " <", + localPart, + "@", + domain, + ">" + ] + +allowedChar :: Char -> Bool +allowedChar c = isAscii c || utf8NonAscii c + +-- | Modified 'unicode' generator from Hedgehog. +unicode :: Gen Char +unicode = + Gen.frequency + [ (55296, Gen.element "!#$%&'*+-/=?^_`{|}~"), + (55296, Gen.alphaNum), + (8190, Gen.filter isPrint (Gen.enum (chr 0xc2) maxBound)) + ] diff --git a/test/isemail.json b/test/isemail.json new file mode 100644 --- /dev/null +++ b/test/isemail.json @@ -0,0 +1,1 @@ +[{"ietId":1,"ietAddr":"","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NODOMAIN"},{"ietId":2,"ietAddr":"test","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NODOMAIN"},{"ietId":3,"ietAddr":"@","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NOLOCALPART"},{"ietId":4,"ietAddr":"test@","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NODOMAIN"},{"ietId":5,"ietAddr":"test@io","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":6,"ietAddr":"@io","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NOLOCALPART"},{"ietId":7,"ietAddr":"@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NOLOCALPART"},{"ietId":8,"ietAddr":"test@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":9,"ietAddr":"test@nominet.org.uk","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":10,"ietAddr":"test@about.museum","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":11,"ietAddr":"a@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":12,"ietAddr":"test@e.com","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"},{"ietId":13,"ietAddr":"test@iana.a","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"},{"ietId":14,"ietAddr":"test.test@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":15,"ietAddr":".test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOT_START"},{"ietId":16,"ietAddr":"test.@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOT_END"},{"ietId":17,"ietAddr":"test..iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CONSECUTIVEDOTS"},{"ietId":18,"ietAddr":"test_exa-mple.com","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_NODOMAIN"},{"ietId":19,"ietAddr":"!%23$%25&%60*+/=?%5E%60%7B%7C%7D~@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":20,"ietAddr":"test%5C@test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":21,"ietAddr":"123@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":22,"ietAddr":"test@123.com","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":23,"ietAddr":"test@iana.123","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_TLDNUMERIC"},{"ietId":24,"ietAddr":"test@255.255.255.255","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_TLDNUMERIC"},{"ietId":25,"ietAddr":"abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklm@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":26,"ietAddr":"abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklmn@iana.org","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_LOCAL_TOOLONG"},{"ietId":27,"ietAddr":"test@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.com","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"},{"ietId":28,"ietAddr":"test@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklm.com","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_LABEL_TOOLONG"},{"ietId":29,"ietAddr":"test@mason-dixon.com","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":30,"ietAddr":"test@-iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOMAINHYPHENSTART"},{"ietId":31,"ietAddr":"test@iana-.com","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOMAINHYPHENEND"},{"ietId":32,"ietAddr":"test@c--n.com","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":33,"ietAddr":"test@iana.co-uk","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"},{"ietId":34,"ietAddr":"test@.iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOT_START"},{"ietId":35,"ietAddr":"test@iana.org.","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOT_END"},{"ietId":36,"ietAddr":"test@iana..com","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CONSECUTIVEDOTS"},{"ietId":37,"ietAddr":"a@a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z.a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z.a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z.a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z.a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"},{"ietId":38,"ietAddr":"abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklm@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghi","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"},{"ietId":39,"ietAddr":"abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklm@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghij","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_TOOLONG"},{"ietId":40,"ietAddr":"a@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefg.hij","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_TOOLONG"},{"ietId":41,"ietAddr":"a@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefg.hijk","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAIN_TOOLONG"},{"ietId":42,"ietAddr":"%22test%22@iana.org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_QUOTEDSTRING"},{"ietId":43,"ietAddr":"%22%22@iana.org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_QUOTEDSTRING"},{"ietId":44,"ietAddr":"%22%22%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":45,"ietAddr":"%22%5Ca%22@iana.org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_QUOTEDSTRING"},{"ietId":46,"ietAddr":"%22%5C%22%22@iana.org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_QUOTEDSTRING"},{"ietId":47,"ietAddr":"%22%5C%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDQUOTEDSTR"},{"ietId":48,"ietAddr":"%22%5C%5C%22@iana.org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_QUOTEDSTRING"},{"ietId":49,"ietAddr":"test%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":50,"ietAddr":"%22test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDQUOTEDSTR"},{"ietId":51,"ietAddr":"%22test%22test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_ATEXT_AFTER_QS"},{"ietId":52,"ietAddr":"test%22text%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":53,"ietAddr":"%22test%22%22test%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":54,"ietAddr":"%22test%22.%22test%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_LOCALPART"},{"ietId":55,"ietAddr":"%22test%5C%20test%22@iana.org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_QUOTEDSTRING"},{"ietId":56,"ietAddr":"%22test%22.test@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_LOCALPART"},{"ietId":57,"ietAddr":"%22test%E2%90%80%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_QTEXT"},{"ietId":58,"ietAddr":"%22test%5C%E2%90%80%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_QP"},{"ietId":59,"ietAddr":"%22abcdefghijklmnopqrstuvwxyz%20abcdefghijklmnopqrstuvwxyz%20abcdefghj%22@iana.org","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_LOCAL_TOOLONG"},{"ietId":60,"ietAddr":"%22abcdefghijklmnopqrstuvwxyz%20abcdefghijklmnopqrstuvwxyz%20abcdefg%5Ch%22@iana.org","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_LOCAL_TOOLONG"},{"ietId":61,"ietAddr":"test@[255.255.255.255]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":62,"ietAddr":"test@a[255.255.255.255]","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":63,"ietAddr":"test@[255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":64,"ietAddr":"test@[255.255.255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":65,"ietAddr":"test@[255.255.255.256]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":66,"ietAddr":"test@[1111:2222:3333:4444:5555:6666:7777:8888]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":67,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666:7777]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_GRPCOUNT"},{"ietId":68,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":69,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888:9999]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_GRPCOUNT"},{"ietId":70,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666:7777:888G]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_BADCHAR"},{"ietId":71,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666::8888]","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_RFC5321_IPV6DEPRECATED"},{"ietId":72,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555::8888]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":73,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666::7777:8888]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_MAXGRPS"},{"ietId":74,"ietAddr":"test@[IPv6::3333:4444:5555:6666:7777:8888]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_COLONSTRT"},{"ietId":75,"ietAddr":"test@[IPv6:::3333:4444:5555:6666:7777:8888]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":76,"ietAddr":"test@[IPv6:1111::4444:5555::8888]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_2X2XCOLON"},{"ietId":77,"ietAddr":"test@[IPv6:::]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":78,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:255.255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_GRPCOUNT"},{"ietId":79,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666:255.255.255.255]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":80,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666:7777:255.255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_GRPCOUNT"},{"ietId":81,"ietAddr":"test@[IPv6:1111:2222:3333:4444::255.255.255.255]","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_ADDRESSLITERAL"},{"ietId":82,"ietAddr":"test@[IPv6:1111:2222:3333:4444:5555:6666::255.255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_MAXGRPS"},{"ietId":83,"ietAddr":"test@[IPv6:1111:2222:3333:4444:::255.255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_2X2XCOLON"},{"ietId":84,"ietAddr":"test@[IPv6::255.255.255.255]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_COLONSTRT"},{"ietId":85,"ietAddr":"%20test%20@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CFWS_NEAR_AT"},{"ietId":86,"ietAddr":"test@%20iana%20.com","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CFWS_NEAR_AT"},{"ietId":87,"ietAddr":"test%20.%20test@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_FWS"},{"ietId":88,"ietAddr":"%E2%90%8D%E2%90%8A%20test@iana.org","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_FWS"},{"ietId":89,"ietAddr":"%E2%90%8D%E2%90%8A%20%E2%90%8D%E2%90%8A%20test@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_FWS"},{"ietId":90,"ietAddr":"(comment)test@iana.org","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_COMMENT"},{"ietId":91,"ietAddr":"((comment)test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDCOMMENT"},{"ietId":92,"ietAddr":"(comment(comment))test@iana.org","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_COMMENT"},{"ietId":93,"ietAddr":"test@(comment)iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CFWS_NEAR_AT"},{"ietId":94,"ietAddr":"test(comment)test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_ATEXT_AFTER_CFWS"},{"ietId":95,"ietAddr":"test@(comment)[255.255.255.255]","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CFWS_NEAR_AT"},{"ietId":96,"ietAddr":"(comment)abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklm@iana.org","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_COMMENT"},{"ietId":97,"ietAddr":"test@(comment)abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghikl.com","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CFWS_NEAR_AT"},{"ietId":98,"ietAddr":"(comment)test@abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghik.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghik.abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijk.abcdefghijklmnopqrstuvwxyzabcdefghijk.abcdefghijklmnopqrstu","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_COMMENT"},{"ietId":99,"ietAddr":"test@iana.org%E2%90%8A","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":100,"ietAddr":"test@xn--hxajbheg2az3al.xn--jxalpdlp","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":101,"ietAddr":"xn--test@iana.org","ietCat":"ISEMAIL_VALID_CATEGORY","ietDia":"ISEMAIL_VALID"},{"ietId":102,"ietAddr":"test@iana.org-","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_DOMAINHYPHENEND"},{"ietId":103,"ietAddr":"%22test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDQUOTEDSTR"},{"ietId":104,"ietAddr":"(test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDCOMMENT"},{"ietId":105,"ietAddr":"test@(iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDCOMMENT"},{"ietId":106,"ietAddr":"test@[1.2.3.4","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDDOMLIT"},{"ietId":107,"ietAddr":"%22test%5C%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDQUOTEDSTR"},{"ietId":108,"ietAddr":"(comment%5C)test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDCOMMENT"},{"ietId":109,"ietAddr":"test@iana.org(comment%5C)","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDCOMMENT"},{"ietId":110,"ietAddr":"test@iana.org(comment%5C","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_BACKSLASHEND"},{"ietId":112,"ietAddr":"test@[RFC-5322-domain-literal]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":113,"ietAddr":"test@[RFC-5322]-domain-literal]","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_ATEXT_AFTER_DOMLIT"},{"ietId":114,"ietAddr":"test@[RFC-5322-[domain-literal]","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_DTEXT"},{"ietId":115,"ietAddr":"test@[RFC-5322-%5C%E2%90%87-domain-literal]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMLIT_OBSDTEXT"},{"ietId":116,"ietAddr":"test@[RFC-5322-%5C%E2%90%89-domain-literal]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMLIT_OBSDTEXT"},{"ietId":117,"ietAddr":"test@[RFC-5322-%5C]-domain-literal]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMLIT_OBSDTEXT"},{"ietId":118,"ietAddr":"test@[RFC-5322-domain-literal%5C]","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_UNCLOSEDDOMLIT"},{"ietId":119,"ietAddr":"test@[RFC-5322-domain-literal%5C","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_BACKSLASHEND"},{"ietId":120,"ietAddr":"test@[RFC%205322%20domain%20literal]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":121,"ietAddr":"test@[RFC-5322-domain-literal]%20(comment)","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAINLITERAL"},{"ietId":122,"ietAddr":"%7F@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":123,"ietAddr":"test@%7F.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":124,"ietAddr":"%22%7F%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_QTEXT"},{"ietId":125,"ietAddr":"%22%5C%7F%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_QP"},{"ietId":126,"ietAddr":"(%7F)test@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CTEXT"},{"ietId":127,"ietAddr":"test@iana.org%E2%90%8D","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CR_NO_LF"},{"ietId":128,"ietAddr":"%E2%90%8Dtest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CR_NO_LF"},{"ietId":129,"ietAddr":"%22%E2%90%8Dtest%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CR_NO_LF"},{"ietId":130,"ietAddr":"(%E2%90%8D)test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CR_NO_LF"},{"ietId":131,"ietAddr":"test@iana.org(%E2%90%8D)","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_CR_NO_LF"},{"ietId":132,"ietAddr":"%E2%90%8Atest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":133,"ietAddr":"%22%E2%90%8A%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_QTEXT"},{"ietId":134,"ietAddr":"%22%5C%E2%90%8A%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_QP"},{"ietId":135,"ietAddr":"(%E2%90%8A)test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_CTEXT"},{"ietId":136,"ietAddr":"%E2%90%87@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":137,"ietAddr":"test@%E2%90%87.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_ATEXT"},{"ietId":138,"ietAddr":"%22%E2%90%87%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_QTEXT"},{"ietId":139,"ietAddr":"%22%5C%E2%90%87%22@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_QP"},{"ietId":140,"ietAddr":"(%E2%90%87)test@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_CTEXT"},{"ietId":141,"ietAddr":"%E2%90%8D%E2%90%8Atest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":142,"ietAddr":"%E2%90%8D%E2%90%8A%20%E2%90%8D%E2%90%8Atest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":143,"ietAddr":"%20%E2%90%8D%E2%90%8Atest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":144,"ietAddr":"%20%E2%90%8D%E2%90%8A%20test@iana.org","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_FWS"},{"ietId":145,"ietAddr":"%20%E2%90%8D%E2%90%8A%20%E2%90%8D%E2%90%8Atest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":146,"ietAddr":"%20%E2%90%8D%E2%90%8A%E2%90%8D%E2%90%8Atest@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_X2"},{"ietId":147,"ietAddr":"%20%E2%90%8D%E2%90%8A%E2%90%8D%E2%90%8A%20test@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_X2"},{"ietId":148,"ietAddr":"test@iana.org%E2%90%8D%E2%90%8A%20","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_FWS"},{"ietId":149,"ietAddr":"test@iana.org%E2%90%8D%E2%90%8A%20%E2%90%8D%E2%90%8A%20","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_FWS"},{"ietId":150,"ietAddr":"test@iana.org%E2%90%8D%E2%90%8A","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":151,"ietAddr":"test@iana.org%E2%90%8D%E2%90%8A%20%E2%90%8D%E2%90%8A","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":152,"ietAddr":"test@iana.org%20%E2%90%8D%E2%90%8A","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":153,"ietAddr":"test@iana.org%20%E2%90%8D%E2%90%8A%20","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_FWS"},{"ietId":154,"ietAddr":"test@iana.org%20%E2%90%8D%E2%90%8A%20%E2%90%8D%E2%90%8A","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_END"},{"ietId":155,"ietAddr":"test@iana.org%20%E2%90%8D%E2%90%8A%E2%90%8D%E2%90%8A","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_X2"},{"ietId":156,"ietAddr":"test@iana.org%20%E2%90%8D%E2%90%8A%E2%90%8D%E2%90%8A%20","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_FWS_CRLF_X2"},{"ietId":157,"ietAddr":"%20test@iana.org","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_FWS"},{"ietId":158,"ietAddr":"test@iana.org%20","ietCat":"ISEMAIL_CFWS","ietDia":"ISEMAIL_CFWS_FWS"},{"ietId":159,"ietAddr":"test@[IPv6:1::2:]","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_IPV6_COLONEND"},{"ietId":160,"ietAddr":"%22test%5C%C2%A9%22@iana.org","ietCat":"ISEMAIL_ERR","ietDia":"ISEMAIL_ERR_EXPECTING_QPAIR"},{"ietId":161,"ietAddr":"test@iana/icann.org","ietCat":"ISEMAIL_RFC5322","ietDia":"ISEMAIL_RFC5322_DOMAIN"},{"ietId":165,"ietAddr":"test.(comment)test@iana.org","ietCat":"ISEMAIL_DEPREC","ietDia":"ISEMAIL_DEPREC_COMMENT"},{"ietId":166,"ietAddr":"test@org","ietCat":"ISEMAIL_RFC5321","ietDia":"ISEMAIL_RFC5321_TLD"},{"ietId":167,"ietAddr":"test@test.com","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_MX_RECORD"},{"ietId":168,"ietAddr":"test@nic.no","ietCat":"ISEMAIL_DNSWARN","ietDia":"ISEMAIL_DNSWARN_NO_RECORD"}]