@@ -1,53 +1,59 @@
2{-# OPTIONS_GHC -Wno-orphans #-}
1{-# OPTIONS_GHC -Wno-orphans #-}
3module Text.Email.Extra
2module Text.Email.Extra
4 ( validateEmail
3 ( validateEmail
5 , emailToText
4 , emailToText
8−import Control.Monad ((<=<))
7+import Control.Monad ((<=<))
9−import Data.ByteString (ByteString)
8+import Data.ByteString (ByteString)
10−import qualified Data.ByteString.Char8 as BSC
9+import qualified Data.ByteString.Char8 as ByteString
11−import Data.Text (Text)
10+import Data.Text (Text)
12−import Data.Text as T (unpack)
13−import Data.Text.Encoding as T (decodeUtf8)
11+import qualified Data.Text.Encoding as Text
14−import Test.QuickCheck
12+import Test.QuickCheck
15−import Text.Email.Validate (EmailAddress)
13+import Text.Email.Validate (EmailAddress)
16−import Text.Email.Validate as Email
14+import qualified Text.Email.Validate as Email
17− (domainPart, toByteString, unsafeEmailAddress, validate)
20−import Text.Regex.PCRE.Heavy (re, (=~))
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.
22validateEmailDomain :: EmailAddress -> Either String EmailAddress
23validateEmailDomain :: EmailAddress -> Either String EmailAddress
23−validateEmailDomain email =
24+validateEmailDomain email
24− if emailDomain =~ domainRegex
25− then Right email
25+ | validDomain domain = Right email
26− else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
26+ | otherwise = Left ("email domain invalid: " <> ByteString.unpack domain)
28− emailDomain = Email.domainPart email
28+ domain = Email.domainPart email
29− domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
29+ validDomain dom
30− errorMessage = "email domain is not valid: " :: String
30+ -- Split domain into chunks,
31−#endif
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.
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
33validateEmail :: ByteString -> Either String EmailAddress
44validateEmail :: ByteString -> Either String EmailAddress
35validateEmail = validateEmailDomain <=< Email.validate
45validateEmail = validateEmailDomain <=< Email.validate
37−validateEmail = error "validateEmail: unimplemented in GHCJS"
40emailToText :: EmailAddress -> Text
47emailToText :: EmailAddress -> Text
42−emailToText = T.decodeUtf8 . toByteString
48+emailToText = Text.decodeUtf8 . Email.toByteString
44−emailToText = error "emailToText: unimplemented in GHCJS"
50+none :: Foldable t => (a -> Bool) -> t a -> Bool
45−#endif
51+none f = not . any f
47instance Arbitrary EmailAddress where
53instance Arbitrary EmailAddress where
48 arbitrary = do
54 arbitrary = do
49 s <- listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
55 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"
51 -- FIXME: write the correct instance
57 -- FIXME: write the correct instance
52 -- arbitrary = do
58 -- arbitrary = do
53 -- m <- elements [1..32]
59 -- m <- elements [1..32]
@@ -66,4 +72,4 @@ instance Arbitrary EmailAddress where
66 -- -- no subdomains
72 -- -- no subdomains
67 -- domain <- replicateM n (elements ['a'..'Z'])
73 -- domain <- replicateM n (elements ['a'..'Z'])
68 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
74 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
69− -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral
75+ -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral