@@ -0,0 +1,65 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module Data.Email
3+ ( Email(..)
4+ , _Email
5+ , _EmailAddress
6+ , toEmail
7+ , _EmailEmailAddress
8+ ) where
9+
10+import Control.Lens hiding (elements)
11+import Control.Monad
12+import Data.Aeson as JSON
13+import Data.ByteString
14+import Data.ByteString.Lens
15+import Data.String
16+import Data.Text as T
17+import Data.Text.Encoding (decodeUtf8)
18+import Data.Text.Lens
19+import Test.QuickCheck.Arbitrary
20+import Test.QuickCheck.Gen (elements)
21+import Text.Email.Parser
22+import Text.Email.Validate (EmailAddress, emailAddress)
23+
24+newtype Email
25+ = Email
26+ { unEmail :: Text
27+ } deriving (Eq, Show, FromJSON, ToJSON, IsString)
28+
29+makePrisms ''Email
30+
31+-- | "Orphaned" prism.
32+_EmailAddress :: Prism' ByteString EmailAddress
33+_EmailAddress = prism' toByteString emailAddress
34+
35+-- | Can be used like this:
36+--
37+-- >>> _EmailEmailAddress # (fromJust $ emailAddress "foo@bar.com")
38+-- Email {unEmail = "foo@bar.com"}
39+--
40+-- >>> Email "foo@bar.com" ^? _EmailEmailAddress
41+-- Just "foo@bar.com"
42+--
43+_EmailEmailAddress :: Prism' Email EmailAddress
44+_EmailEmailAddress = prism'
45+ toEmail
46+ (^? _Email . unpacked . packedChars . _EmailAddress)
47+
48+instance Arbitrary Email where
49+ arbitrary = do
50+ user <- elements ["user", "foo", "bar" :: Text]
51+ host <- elements ["example.com", "gmail.com" :: Text]
52+ return $ Email $ user <> host
53+
54+instance ToJSON EmailAddress where
55+ toJSON = toJSON . view (re _EmailEmailAddress . _Email)
56+
57+instance FromJSON EmailAddress where
58+ parseJSON = withText "EmailAddress" $ \s -> do
59+ let ea = s ^? re _Email . _EmailEmailAddress
60+ case ea of
61+ Just x -> pure x
62+ Nothing -> mzero
63+
64+toEmail :: EmailAddress -> Email
65+toEmail = Email . decodeUtf8 . toByteString