@@ -1,120 +1,41 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
21{-# LANGUAGE CPP #-}
3−
42module Text.Email.Extra
53 ( validateEmail
64 , emailToText
75 ) where
86
9−import Control.Monad ((<=<))
10−import Data.ByteString (ByteString)
11−import qualified Data.ByteString.Char8 as ByteString
12−import Data.Text (Text)
13−import qualified Data.Text.Encoding as Text
14−import qualified Text.Email.Validate as Email
15−import Text.Email.Validate (EmailAddress)
16−#ifdef ARBITRARY
17−import Test.QuickCheck
18−#endif
19−#ifdef POSTGRES
20−import Data.CaseInsensitive as CI hiding (map)
21−import Database.PostgreSQL.Simple.FromField as PG
22−import Database.PostgreSQL.Simple.ToField as PG
23−#endif
24−#ifdef AESON
25−import Control.Monad
26−import Data.Aeson
27−#endif
28−#ifdef SCHEMA
29−import Data.OpenApi
30−import Data.Proxy
31−#endif
7+import Control.Monad ((<=<))
8+import Data.ByteString (ByteString)
9+import Data.Text (Text)
10+import Data.Text as T (unpack)
11+import Data.Text.Encoding as T (decodeUtf8)
12+import Text.Email.Validate (EmailAddress)
13+import Text.Email.Validate as Email (validate, domainPart, toByteString)
14+
15+#ifndef ghcjs_HOST_OS
16+import Text.Regex.PCRE.Heavy (re, (=~))
3217
33−-- | Validate that the domain part in this email address is
34−-- in fact a domain name.
35−-- The old version of this function used the following regular expression
36−-- to validate email domains:
37−-- > domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
38−-- It was rewritten without regex to make this library more portable and
39−-- allow using it with GHCJS.
4018validateEmailDomain :: EmailAddress -> Either String EmailAddress
41−validateEmailDomain email
42− | validDomain domain = Right email
43− | otherwise = Left ("email domain invalid: " <> ByteString.unpack domain)
19+validateEmailDomain email =
20+ if emailDomain =~ domainRegex
21+ then Right email
22+ else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
4423 where
45− domain = Email.domainPart email
46− validDomain dom
47− -- Split domain into chunks,
48− -- i.e. awesome.typeable.io -> [awesome typeable io]
49− | chunks <- ByteString.split '.' dom
50− -- Check that there are at least two chunks,
51− -- do not allow one word domains.
52− , length chunks >= 2
53− -- Check that there are no empty chunks. This would happen if the domain
54− -- starts or ends with '.' or has two or more dots next to one another.
55− , not $ any ByteString.null chunks
56− -- Finally, check that the last chunk (TLD) is two or more
57− -- characters long, since there are no single-character top domains.
58− , ByteString.length (last chunks) >= 2 = True
59− | otherwise = False
24+ emailDomain = Email.domainPart email
25+ domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
26+ errorMessage = "email domain is not valid: " :: String
27+#endif
6028
6129validateEmail :: ByteString -> Either String EmailAddress
30+#ifndef ghcjs_HOST_OS
6231validateEmail = validateEmailDomain <=< Email.validate
63−
64−emailToText :: EmailAddress -> Text
65−emailToText = Text.decodeUtf8 . Email.toByteString
66−
67−#ifdef ARBITRARY
68−instance Arbitrary EmailAddress where
69− arbitrary = do
70− s <- take 64 <$> listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
71− return $ Email.unsafeEmailAddress (ByteString.pack s) "antorica.com"
72− -- FIXME: write the correct instance
73− -- arbitrary = do
74− -- m <- elements [1..32]
75− -- n <- elements [1..32]
76− -- let
77− -- localGen = do
78− -- let
79− -- alphabets = T.pack $ ['a'..'Z']
80− -- digits = T.pack $ ['0'..'9']
81− -- alphaNum = alphabets <> digits
82− -- symbols = "-!#$%&'*+-/=?^_`{|}~."
83− -- localSym = alphaNum <> symbols
84− -- encodeUtf8 <$> (replicateM m (elements localSym)
85− -- `suchThat` (isRight . parseOnly localPart))
86− -- local <- localGen
87− -- -- no subdomains
88− -- domain <- replicateM n (elements ['a'..'Z'])
89− -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
90− -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral
32+#else
33+validateEmail = error "validateEmail: unimplemented in GHCJS"
9134#endif
9235
93−#ifdef POSTGRES
94−instance ToField EmailAddress where
95− toField = toField . CI.mk . emailToText
96−
97−instance FromField EmailAddress where
98− fromField f mbs = do
99− ci <- fromField f mbs
100− case validateEmail $ Text.encodeUtf8 $ CI.original ci of
101− Left _ -> returnError ConversionFailed f "EmailAddress is not parseable"
102− Right a -> return a
103−#endif
104−
105−#ifdef AESON
106−instance ToJSON EmailAddress where
107− toEncoding = toEncoding . emailToText
108− toJSON = toJSON . emailToText
109−
110−instance FromJSON EmailAddress where
111− parseJSON = parseJSON >=> either fail pure . validateEmail . Text.encodeUtf8
112−#endif
113−
114−#ifdef SCHEMA
115−instance ToSchema EmailAddress where
116− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Text)
117−
118−instance ToParamSchema EmailAddress where
119− toParamSchema _ = toParamSchema (Proxy :: Proxy Text)
36+emailToText :: EmailAddress -> Text
37+#ifndef ghcjs_HOST_OS
38+emailToText = T.decodeUtf8 . toByteString
39+#else
40+emailToText = error "emailToText: unimplemented in GHCJS"
12041#endif