@@ -1,41 +1,120 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
2module Text.Email.Extra
4module Text.Email.Extra
3 ( validateEmail
5 ( validateEmail
4 , emailToText
6 , emailToText
7−import Control.Monad ((<=<))
9+import Control.Monad ((<=<))
8−import Data.ByteString (ByteString)
10+import Data.ByteString (ByteString)
9−import Data.Text (Text)
11+import qualified Data.ByteString.Char8 as ByteString
10−import Data.Text as T (unpack)
12+import Data.Text (Text)
11−import Data.Text.Encoding as T (decodeUtf8)
13+import qualified Data.Text.Encoding as Text
12−import Text.Email.Validate (EmailAddress)
14+import qualified Text.Email.Validate as Email
13−import Text.Email.Validate as Email (validate, domainPart, toByteString)
15+import Text.Email.Validate (EmailAddress)
15−#ifndef ghcjs_HOST_OS
17+import Test.QuickCheck
16−import Text.Regex.PCRE.Heavy (re, (=~))
18+#endif
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.
18validateEmailDomain :: EmailAddress -> Either String EmailAddress
40validateEmailDomain :: EmailAddress -> Either String EmailAddress
19−validateEmailDomain email =
41+validateEmailDomain email
20− if emailDomain =~ domainRegex
21− then Right email
42+ | validDomain domain = Right email
22− else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
43+ | otherwise = Left ("email domain invalid: " <> ByteString.unpack domain)
24− emailDomain = Email.domainPart email
45+ domain = Email.domainPart email
25− domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
46+ validDomain dom
26− errorMessage = "email domain is not valid: " :: String
47+ -- Split domain into chunks,
27−#endif
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.
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
29validateEmail :: ByteString -> Either String EmailAddress
61validateEmail :: ByteString -> Either String EmailAddress
31validateEmail = validateEmailDomain <=< Email.validate
62validateEmail = validateEmailDomain <=< Email.validate
33−validateEmail = error "validateEmail: unimplemented in GHCJS"
36emailToText :: EmailAddress -> Text
64emailToText :: EmailAddress -> Text
38−emailToText = T.decodeUtf8 . toByteString
65+emailToText = Text.decodeUtf8 . Email.toByteString
40−emailToText = error "emailToText: unimplemented in GHCJS"
67+#ifdef ARBITRARY
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
94+instance ToField EmailAddress where
95+ toField = toField . CI.mk . emailToText
97+instance FromField EmailAddress where
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)