@@ -1,17 +1,29 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
2+{-# LANGUAGE CPP #-}
23module Text.Email.Extra
34 ( validateEmail
45 , emailToText
56 ) where
67
7−import Control.Monad ((<=<))
8−import Data.ByteString (ByteString)
9−import qualified Data.ByteString.Char8 as ByteString
10−import Data.Text (Text)
11−import qualified Data.Text.Encoding as Text
12−import Test.QuickCheck
13−import Text.Email.Validate (EmailAddress)
14−import qualified Text.Email.Validate as Email
8+import Control.Monad ((<=<))
9+import Data.ByteString (ByteString)
10+import qualified Data.ByteString.Char8 as ByteString
11+import Data.Text (Text)
12+import qualified Data.Text.Encoding as Text
13+import qualified Text.Email.Validate as Email
14+import Text.Email.Validate (EmailAddress)
15+#ifdef ARBITRARY
16+import Test.QuickCheck
17+#endif
18+#ifdef POSTGRES
19+import Data.CaseInsensitive as CI hiding (map)
20+import Database.PostgreSQL.Simple.FromField as PG
21+import Database.PostgreSQL.Simple.ToField as PG
22+#endif
23+#ifdef AESON
24+import Control.Monad
25+import Data.Aeson
26+#endif
1527
1628-- | Validate that the domain part in this email address is
1729-- in fact a domain name.
@@ -35,7 +47,7 @@ validateEmailDomain email
3547 , length chunks >= 2
3648 -- Check that there are no empty chunks. This would happen if the domain
3749 -- starts or ends with '.' or has two or more dots next to one another.
38− , none (ByteString.null) chunks
50+ , not $ any ByteString.null chunks
3951 -- Finally, check that the last chunk (TLD) is two or more
4052 -- characters long, since there are no single-character top domains.
4153 , ByteString.length (last chunks) >= 2 = True
@@ -47,9 +59,7 @@ validateEmail = validateEmailDomain <=< Email.validate
4759emailToText :: EmailAddress -> Text
4860emailToText = Text.decodeUtf8 . Email.toByteString
4961
50−none :: Foldable t => (a -> Bool) -> t a -> Bool
51−none f = not . any f
52−
62+#ifdef ARBITRARY
5363instance Arbitrary EmailAddress where
5464 arbitrary = do
5565 s <- take 64 <$> listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
@@ -73,3 +83,25 @@ instance Arbitrary EmailAddress where
7383 -- domain <- replicateM n (elements ['a'..'Z'])
7484 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
7585 -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral
86+#endif
87+
88+#ifdef POSTGRES
89+instance ToField EmailAddress where
90+ toField = toField . CI.mk . emailToText
91+
92+instance FromField EmailAddress where
93+ fromField f mbs = do
94+ ci <- fromField f mbs
95+ case validateEmail $ Text.encodeUtf8 $ CI.original ci of
96+ Left _ -> returnError ConversionFailed f "EmailAddress is not parseable"
97+ Right a -> return a
98+#endif
99+
100+#ifdef AESON
101+instance ToJSON EmailAddress where
102+ toEncoding = toEncoding . emailToText
103+ toJSON = toJSON . emailToText
104+
105+instance FromJSON EmailAddress where
106+ parseJSON = parseJSON >=> either fail pure . validateEmail . Text.encodeUtf8
107+#endif