@@ -1,120 +1,41 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
4module Text.Email.Extra
2module Text.Email.Extra
5 ( validateEmail
3 ( validateEmail
6 , emailToText
4 , emailToText
9−import Control.Monad ((<=<))
7+import Control.Monad ((<=<))
10−import Data.ByteString (ByteString)
8+import Data.ByteString (ByteString)
11−import qualified Data.ByteString.Char8 as ByteString
9+import Data.Text (Text)
12−import Data.Text (Text)
10+import Data.Text as T (unpack)
13−import qualified Data.Text.Encoding as Text
11+import Data.Text.Encoding as T (decodeUtf8)
14−import qualified Text.Email.Validate as Email
12+import Text.Email.Validate (EmailAddress)
15−import Text.Email.Validate (EmailAddress)
13+import Text.Email.Validate as Email (validate, domainPart, toByteString)
17−import Test.QuickCheck
15+#ifndef ghcjs_HOST_OS
18−#endif
16+import Text.Regex.PCRE.Heavy (re, (=~))
20−import Data.CaseInsensitive as CI hiding (map)
21−import Database.PostgreSQL.Simple.FromField as PG
22−import Database.PostgreSQL.Simple.ToField as PG
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.
40validateEmailDomain :: EmailAddress -> Either String EmailAddress
18validateEmailDomain :: EmailAddress -> Either String EmailAddress
41−validateEmailDomain email
19+validateEmailDomain email =
20+ if emailDomain =~ domainRegex
42− | validDomain domain = Right email
21+ then Right email
43− | otherwise = Left ("email domain invalid: " <> ByteString.unpack domain)
22+ else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
45− domain = Email.domainPart email
24+ emailDomain = Email.domainPart email
46− validDomain dom
25+ domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
47− -- Split domain into chunks,
26+ errorMessage = "email domain is not valid: " :: String
48− -- i.e. awesome.typeable.io -> [awesome typeable io]
27+#endif
49− | chunks <- ByteString.split '.' dom
50− -- Check that there are at least two chunks,
51− -- do not allow one word domains.
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
61validateEmail :: ByteString -> Either String EmailAddress
29validateEmail :: ByteString -> Either String EmailAddress
62validateEmail = validateEmailDomain <=< Email.validate
31validateEmail = validateEmailDomain <=< Email.validate
64−emailToText :: EmailAddress -> Text
33+validateEmail = error "validateEmail: unimplemented in GHCJS"
65−emailToText = Text.decodeUtf8 . Email.toByteString
68−instance Arbitrary EmailAddress where
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
74− -- m <- elements [1..32]
75− -- n <- elements [1..32]
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))
88− -- domain <- replicateM n (elements ['a'..'Z'])
89− -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
90− -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral
93−#ifdef POSTGRES
36+emailToText :: EmailAddress -> Text
94−instance ToField EmailAddress where
37+#ifndef ghcjs_HOST_OS
95− toField = toField . CI.mk . emailToText
38+emailToText = T.decodeUtf8 . toByteString
97−instance FromField EmailAddress where
40+emailToText = error "emailToText: unimplemented in GHCJS"
99− ci <- fromField f mbs
100− case validateEmail $ Text.encodeUtf8 $ CI.original ci of
101− Left _ -> returnError ConversionFailed f "EmailAddress is not parseable"
106−instance ToJSON EmailAddress where
107− toEncoding = toEncoding . emailToText
108− toJSON = toJSON . emailToText
110−instance FromJSON EmailAddress where
111− parseJSON = parseJSON >=> either fail pure . validateEmail . Text.encodeUtf8
115−instance ToSchema EmailAddress where
116− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Text)
118−instance ToParamSchema EmailAddress where
119− toParamSchema _ = toParamSchema (Proxy :: Proxy Text)