@@ -1,53 +1,59 @@
1−{-# LANGUAGE CPP #-}
21{-# OPTIONS_GHC -Wno-orphans #-}
32module Text.Email.Extra
43 ( validateEmail
54 , emailToText
65 ) where
76
8−import Control.Monad ((<=<))
9−import Data.ByteString (ByteString)
10−import qualified Data.ByteString.Char8 as BSC
11−import Data.Text (Text)
12−import Data.Text as T (unpack)
13−import Data.Text.Encoding as T (decodeUtf8)
14−import Test.QuickCheck
15−import Text.Email.Validate (EmailAddress)
16−import Text.Email.Validate as Email
17− (domainPart, toByteString, unsafeEmailAddress, validate)
18−
19−#ifndef ghcjs_HOST_OS
20−import Text.Regex.PCRE.Heavy (re, (=~))
7+import Control.Monad ((<=<))
8+import Data.ByteString (ByteString)
9+import qualified Data.ByteString.Char8 as ByteString
10+import Data.Text (Text)
11+import qualified Data.Text.Encoding as Text
12+import Test.QuickCheck
13+import Text.Email.Validate (EmailAddress)
14+import qualified Text.Email.Validate as Email
2115
16+-- | Validate that the domain part in this email address is
17+-- in fact a domain name.
18+-- The old version of this function used the following regular expression
19+-- to validate email domains:
20+-- > domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
21+-- It was rewritten without regex to make this library more portable and
22+-- allow using it with GHCJS.
2223validateEmailDomain :: EmailAddress -> Either String EmailAddress
23−validateEmailDomain email =
24− if emailDomain =~ domainRegex
25− then Right email
26− else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
24+validateEmailDomain email
25+ | validDomain domain = Right email
26+ | otherwise = Left ("email domain invalid: " <> ByteString.unpack domain)
2727 where
28− emailDomain = Email.domainPart email
29− domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
30− errorMessage = "email domain is not valid: " :: String
31−#endif
28+ domain = Email.domainPart email
29+ validDomain dom
30+ -- Split domain into chunks,
31+ -- i.e. awesome.typeable.io -> [awesome typeable io]
32+ | chunks <- ByteString.split '.' dom
33+ -- Check that there are at least two chunks,
34+ -- do not allow one word domains.
35+ , length chunks >= 2
36+ -- Check that there are no empty chunks. This would happen if the domain
37+ -- starts or ends with '.' or has two or more dots next to one another.
38+ , none (ByteString.null) chunks
39+ -- Finally, check that the last chunk (TLD) is two or more
40+ -- characters long, since there are no single-character top domains.
41+ , ByteString.length (last chunks) >= 2 = True
42+ | otherwise = False
3243
3344validateEmail :: ByteString -> Either String EmailAddress
34−#ifndef ghcjs_HOST_OS
3545validateEmail = validateEmailDomain <=< Email.validate
36−#else
37−validateEmail = error "validateEmail: unimplemented in GHCJS"
38−#endif
3946
4047emailToText :: EmailAddress -> Text
41−#ifndef ghcjs_HOST_OS
42−emailToText = T.decodeUtf8 . toByteString
43−#else
44−emailToText = error "emailToText: unimplemented in GHCJS"
45−#endif
48+emailToText = Text.decodeUtf8 . Email.toByteString
49+
50+none :: Foldable t => (a -> Bool) -> t a -> Bool
51+none f = not . any f
4652
4753instance Arbitrary EmailAddress where
4854 arbitrary = do
4955 s <- listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
50− return $ unsafeEmailAddress (BSC.pack s) "example.com"
56+ return $ Email.unsafeEmailAddress (ByteString.pack s) "example.com"
5157 -- FIXME: write the correct instance
5258 -- arbitrary = do
5359 -- m <- elements [1..32]
@@ -66,4 +72,4 @@ instance Arbitrary EmailAddress where
6672 -- -- no subdomains
6773 -- domain <- replicateM n (elements ['a'..'Z'])
6874 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
69− -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral
75+ -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral