diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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;gi[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-"] diff --git a/html-email-validate.cabal b/html-email-validate.cabal new file mode 100644 --- /dev/null +++ b/html-email-validate.cabal @@ -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 . + + 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 . +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 diff --git a/src/Text/Html/Email/Validate.hs b/src/Text/Html/Email/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Email/Validate.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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;gi[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) + ] +