@@ -1,17 +1,34 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
2+{-# 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 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
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
1532
1633-- | Validate that the domain part in this email address is
1734-- in fact a domain name.
@@ -35,7 +52,7 @@ validateEmailDomain email
3552 , length chunks >= 2
3653 -- Check that there are no empty chunks. This would happen if the domain
3754 -- 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
3956 -- Finally, check that the last chunk (TLD) is two or more
4057 -- characters long, since there are no single-character top domains.
4158 , ByteString.length (last chunks) >= 2 = True
@@ -47,9 +64,7 @@ validateEmail = validateEmailDomain <=< Email.validate
4764emailToText :: EmailAddress -> Text
4865emailToText = Text.decodeUtf8 . Email.toByteString
4966
50−none :: Foldable t => (a -> Bool) -> t a -> Bool
51−none f = not . any f
52−
67+#ifdef ARBITRARY
5368instance Arbitrary EmailAddress where
5469 arbitrary = do
5570 s <- take 64 <$> listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
@@ -73,3 +88,33 @@ instance Arbitrary EmailAddress where
7388 -- domain <- replicateM n (elements ['a'..'Z'])
7489 -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
7590 -- 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)
120+#endif