html-email-validate (empty) → 0.1.0.0
raw patch · 6 files changed
+292/−0 lines, 6 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed
Dependencies added: QuickCheck, attoparsec, base, criterion, hspec, html-email-validate, regex-pcre-builtin, text, text-show
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/Main.hs +48/−0
- html-email-validate.cabal +55/−0
- src/Text/Html/Email/Validate.hs +80/−0
- tests/Main.hs +77/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Konstantin Zudov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Konstantin Zudov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Criterion.Main+import Text.Html.Email.Validate+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T++main :: IO ()+main = defaultMain [+ bgroup "Valid emails" $ + map (\email -> bench (unpack email) $ whnf isValidEmail email) validEmails+ , bgroup "Invalid emails" $ + map (\email -> bench (unpack email) $ whnf isValidEmail email) invalidEmails+ , bgroup "Long emails" $ + map (\email -> bench (unpack $ T.take 15 email) $ whnf isValidEmail email) longEmails+ ]++validEmails :: [Text]+validEmails = [ "niceandsimple@example.com"+ , "very.common@example.com"+ , "a.little.lengthy.but.fine@dept.example.com"+ , "disposable.style.email.with+symbol@example.com"+ , "other.email-with-dash@example.com"+ , "admin@mailserver1"+ , "!#$%&'*+-/=?^_`{}|~@example.org"+ , "john..doe@example.com"+ ]++invalidEmails :: [Text]+invalidEmails = [ "\"much.more unusual\"@example.com"+ , "\"very.unusual.@.unusual.com\"@example.com"+ , "\"very.(),:;<>[]\\\".VERY.\\\"very@\\\\ \\\"very\\\".unusual\"@strange.example.com"+ , "\"()<>[]:,;@\\\"!#$%&'*+-/=?^_`{}| ~.a\"@example.org","\" \"@example.org"+ , "\252\241\238\231\248\240\233@example.com"+ , "\252\241\238\231\248\240\233@\252\241\238\231\248\240\233.com"+ , "Abc.example.com"+ , "A@b@c@example.com","a\"b(c)d,e:f;g<h>i[j\\k]l@example.com"+ , "just\"not\"right@example.com"+ , "this is\"not\allowed@example.com"+ , "this\\ still\\\"not\\\\allowed@example.com"+ , "john.doe@example..com"]++longEmails :: [Text]+longEmails = map longEmail [3 .. 20]++longEmail :: Int -> Text+longEmail n = T.concat ["john.doe@", T.replicate n "longey-"]
+ html-email-validate.cabal view
@@ -0,0 +1,55 @@+name: html-email-validate+version: 0.1.0.0+synopsis: Validating an email address against HTML standard+description: The library allows to validate and parse an email address+ as it's defined in <https://html.spec.whatwg.org/multipage/forms.html#valid-e-mail-address HTML standard>.++ Note that HTML specification of a valid email address is a+ 'willful violation' of RFC 5322. If you want to validate+ an address against RFC 5322 you should use <https://hackage.haskell.org/package/email-validate email-validate>.+license: BSD3+license-file: LICENSE+author: Konstantin Zudov+maintainer: konstantin@anche.no+copyright: (c) Konstantin Zudov, 2015+category: Text+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Text.Html.Email.Validate+ other-extensions: OverloadedStrings+ RecordWildCards+ DeriveDataTypeable+ DeriveGeneric+ + build-depends: base >=4.0 && <5.0+ , text-show+ , attoparsec+ , text+ + hs-source-dirs: src/+ default-language: Haskell2010+ ghc-options: -Wall ++test-suite test+ hs-source-dirs: tests/+ main-is: Main.hs+ type: exitcode-stdio-1.0+ build-depends: base >= 4.7 && < 4.8+ , attoparsec+ , hspec+ , text+ , regex-pcre-builtin+ , html-email-validate+ , QuickCheck+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ build-depends: base+ , html-email-validate+ , text+ , criterion
+ src/Text/Html/Email/Validate.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+module Text.Html.Email.Validate+ ( -- * Validating+ isValidEmail+ -- * Parsing+ , EmailAddress(..)+ , emailToText+ , parseEmail+ , emailParser+ ) where++import Control.Applicative+import Control.Monad (when)+import Data.Text (Text, intercalate)+import qualified Data.Text as T+import Data.Attoparsec.Text+import Data.Monoid ((<>))+import qualified Text.Read as Read+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import qualified Text.Show.Text as TS++-- | Represents an email address+data EmailAddress = EmailAddress { localPart :: Text+ , domainPart :: Text + } deriving (Eq, Ord, Data, Typeable, Generic)++instance Show EmailAddress where+ show = TS.toString . TS.showb++instance Read EmailAddress where+ readListPrec = Read.readListPrecDefault+ readPrec = Read.parens $ do+ text <- Read.readPrec+ either (const Read.pfail) return $ parseOnly emailParser text++instance TS.Show EmailAddress where+ showb EmailAddress{..} = TS.fromText localPart <> TS.singleton '@' <> TS.fromText domainPart++-- | Convert to text. Note that 'EmailAddress' has an instance of 'TS.Show' from+-- 'text-show', you might want to use it instead.+--+-- >>> emailToText $ EmailAddress "name" "example.com"+-- "name@example.com+emailToText :: EmailAddress -> Text+emailToText = TS.show++-- | Validates given email. Email shouldn't have trailing or preceding spaces+-- +-- >>> :set -XOverloadedStrings+-- >>> isValidEmail "name@example.com"+-- True+-- >>> isValidEmail "name@example..com"+-- False+isValidEmail :: Text -> Bool+isValidEmail = either (const False) (const True) . parseEmail++-- | Parce an email. Error messages aren't very helpful.+parseEmail :: Text -> Either String EmailAddress+parseEmail = parseOnly emailParser++-- | Attoparsec parser.+emailParser :: Parser EmailAddress+emailParser = EmailAddress <$> (local <* char '@') + <*> (domain <* endOfInput)+ +local :: Parser Text+local = takeWhile1 (inClass "A-Za-z0-9!#$%&'*+/=?^_`{|}~.-")++domain :: Parser Text+domain = intercalate "." <$> label `sepBy1` char '.'++label :: Parser Text+label = do+ lbl <- intercalate "-" <$> takeWhile1 (inClass "A-Za-z0-9") `sepBy1` char '-'+ when (T.length lbl > 63) $ fail "Label is too long"+ return lbl
+ tests/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Test.Hspec+import Test.Hspec.QuickCheck+import Text.Regex.PCRE+import Control.Monad+import Data.Text (Text, unpack, pack)+import qualified Data.Text as T+import Test.QuickCheck+import Data.Monoid++import Text.Html.Email.Validate++main :: IO ()+main = hspec $ do+ describe "Checking the correctness of parsing" $ do+ forM_ validEmails $ \(raw,parsed) -> do+ it (unpack raw) $ do+ parseEmail raw `shouldBe` Right parsed++ describe "Checking against the regex" $ do+ describe "Emails from wikipedia:" $ do+ forM_ (map unpack emails) $ \email -> do+ it email $ do+ testEmail email+ describe "QuickCheck property:" $ do+ modifyMaxSuccess (const 100000) $ prop "random@random:" $+ \local domain -> testEmail $ local ++ "@" ++ domain++ {-describe "Very long label:" $ do-}+ {-it "really long" $ isValidEmail ("j@aa" <> T.replicate 10000000 "-a") `shouldBe` False-}++testEmail email = (isValidEmail $ pack email) `shouldBe` validateEmailRegex email+ ++validateEmailRegex email+ | any (== '\n') email = False -- For some reason when using Text.Regex.PCRE+ -- the javascript regex matches '\n' even + -- though when the same regex is used in + -- javascript it doesn't+ | otherwise = email =~ emailRegex++emailRegex = "^[a-zA-Z0-9.!#$%&'*+\\/=?^_`{|}~-]+@[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?(?:\\.[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?)*$" :: String++emails :: [Text]+emails = map fst validEmails ++ invalidEmails++validEmails :: [(Text, EmailAddress)]+validEmails = [ ("niceandsimple@example.com", EmailAddress "niceandsimple" "example.com")+ , ("very.common@example.com", EmailAddress "very.common" "example.com")+ , ("a.little.lengthy.but.fine@dept.example.com", EmailAddress "a.little.lengthy.but.fine" "dept.example.com")+ , ("disposable.style.email.with+symbol@example.com", EmailAddress "disposable.style.email.with+symbol" "example.com")+ , ("other.email-with-dash@example.com", EmailAddress "other.email-with-dash" "example.com")+ , ("admin@mailserver1", EmailAddress "admin" "mailserver1")+ , ("!#$%&'*+-/=?^_`{}|~@example.org", EmailAddress "!#$%&'*+-/=?^_`{}|~" "example.org")+ , ("john..doe@example.com", EmailAddress "john..doe" "example.com")+ , let domain = "a" <> T.replicate 31 "-a"+ in ("j@" <> domain, EmailAddress "j" domain) -- 63 characters in one label (maximum)+ ]++invalidEmails :: [Text]+invalidEmails = [ "\"much.more unusual\"@example.com"+ , "\"very.unusual.@.unusual.com\"@example.com"+ , "\"very.(),:;<>[]\\\".VERY.\\\"very@\\\\ \\\"very\\\".unusual\"@strange.example.com"+ , "\"()<>[]:,;@\\\"!#$%&'*+-/=?^_`{}| ~.a\"@example.org","\" \"@example.org"+ , "\252\241\238\231\248\240\233@example.com"+ , "\252\241\238\231\248\240\233@\252\241\238\231\248\240\233.com"+ , "Abc.example.com"+ , "A@b@c@example.com","a\"b(c)d,e:f;g<h>i[j\\k]l@example.com"+ , "just\"not\"right@example.com"+ , "this is\"not\allowed@example.com"+ , "this\\ still\\\"not\\\\allowed@example.com"+ , "john.doe@example..com"+ , "j@aa" <> T.replicate 31 "-a" -- 64 characters in one label (just out of limit)+ ]+