@@ -1,17 +1,34 @@
1{-# OPTIONS_GHC -Wno-orphans #-}
1{-# OPTIONS_GHC -Wno-orphans #-}
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 qualified Data.ByteString.Char8 as ByteString
11+import qualified Data.ByteString.Char8 as ByteString
10−import Data.Text (Text)
12+import Data.Text (Text)
11−import qualified Data.Text.Encoding as Text
13+import qualified Data.Text.Encoding as Text
14+import qualified Text.Email.Validate as Email
15+import Text.Email.Validate (EmailAddress)
12−import Test.QuickCheck
17+import Test.QuickCheck
13−import Text.Email.Validate (EmailAddress)
18+#endif
14−import qualified Text.Email.Validate as Email
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
16-- | Validate that the domain part in this email address is
33-- | Validate that the domain part in this email address is
17-- in fact a domain name.
34-- in fact a domain name.
@@ -35,7 +52,7 @@ validateEmailDomain email
35 , length chunks >= 2
52 , length chunks >= 2
36 -- Check that there are no empty chunks. This would happen if the domain
53 -- 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.
54 -- starts or ends with '.' or has two or more dots next to one another.
38− , none (ByteString.null) chunks
55+ , not $ any ByteString.null chunks
39 -- Finally, check that the last chunk (TLD) is two or more
56 -- Finally, check that the last chunk (TLD) is two or more
40 -- characters long, since there are no single-character top domains.
57 -- characters long, since there are no single-character top domains.
41 , ByteString.length (last chunks) >= 2 = True
58 , ByteString.length (last chunks) >= 2 = True
@@ -47,9 +64,7 @@ validateEmail = validateEmailDomain <=< Email.validate
47emailToText :: EmailAddress -> Text
64emailToText :: EmailAddress -> Text
48emailToText = Text.decodeUtf8 . Email.toByteString
65emailToText = Text.decodeUtf8 . Email.toByteString
50−none :: Foldable t => (a -> Bool) -> t a -> Bool
67+#ifdef ARBITRARY
53instance Arbitrary EmailAddress where
68instance Arbitrary EmailAddress where
54 arbitrary = do
69 arbitrary = do
55 s <- take 64 <$> listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
70 s <- take 64 <$> listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
@@ -73,3 +88,33 @@ instance Arbitrary EmailAddress where
73 -- domain <- replicateM n (elements ['a'..'Z'])
88 -- domain <- replicateM n (elements ['a'..'Z'])
74 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
89 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
75 -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral
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)