@@ -1,41 +1,120 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
12{-# LANGUAGE CPP #-}
3+
24module Text.Email.Extra
35 ( validateEmail
46 , emailToText
57 ) where
68
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, (=~))
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
1732
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.
1840validateEmailDomain :: EmailAddress -> Either String EmailAddress
19−validateEmailDomain email =
20− if emailDomain =~ domainRegex
21− then Right email
22− else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
41+validateEmailDomain email
42+ | validDomain domain = Right email
43+ | otherwise = Left ("email domain invalid: " <> ByteString.unpack domain)
2344 where
24− emailDomain = Email.domainPart email
25− domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
26− errorMessage = "email domain is not valid: " :: String
27−#endif
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
2860
2961validateEmail :: ByteString -> Either String EmailAddress
30−#ifndef ghcjs_HOST_OS
3162validateEmail = validateEmailDomain <=< Email.validate
32−#else
33−validateEmail = error "validateEmail: unimplemented in GHCJS"
34−#endif
3563
3664emailToText :: EmailAddress -> Text
37−#ifndef ghcjs_HOST_OS
38−emailToText = T.decodeUtf8 . toByteString
39−#else
40−emailToText = error "emailToText: unimplemented in GHCJS"
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
91+#endif
92+
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)
41120#endif