@@ -1,19 +1,23 @@
11{-# LANGUAGE CPP #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
23module Text.Email.Extra
34 ( validateEmail
45 , emailToText
56 ) where
67
7−import Control.Monad ((<=<))
8−import Data.ByteString (ByteString)
9−import Data.Text (Text)
10−import Data.Text as T (unpack)
11−import Data.Text.Encoding as T (decodeUtf8)
12−import Text.Email.Validate (EmailAddress)
13−import Text.Email.Validate as Email (validate, domainPart, toByteString)
8+import Control.Monad ((<=<))
9+import Data.ByteString (ByteString)
10+import qualified Data.ByteString.Char8 as BSC
11+import Data.Text (Text)
12+import Data.Text as T (unpack)
13+import Data.Text.Encoding as T (decodeUtf8)
14+import Test.QuickCheck
15+import Text.Email.Validate (EmailAddress)
16+import Text.Email.Validate as Email
17+ (domainPart, toByteString, unsafeEmailAddress, validate)
1418
1519#ifndef ghcjs_HOST_OS
16−import Text.Regex.PCRE.Heavy (re, (=~))
20+import Text.Regex.PCRE.Heavy (re, (=~))
1721
1822validateEmailDomain :: EmailAddress -> Either String EmailAddress
1923validateEmailDomain email =
@@ -21,8 +25,8 @@ validateEmailDomain email =
2125 then Right email
2226 else Left $ errorMessage <> (T.unpack $ T.decodeUtf8 emailDomain)
2327 where
24− emailDomain = Email.domainPart email
25− domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
28+ emailDomain = Email.domainPart email
29+ domainRegex = [re|^[^.]+(?:\.[^.]+)*\.[^.]{2,}$|]
2630 errorMessage = "email domain is not valid: " :: String
2731#endif
2832
@@ -39,3 +43,27 @@ emailToText = T.decodeUtf8 . toByteString
3943#else
4044emailToText = error "emailToText: unimplemented in GHCJS"
4145#endif
46+
47+instance Arbitrary EmailAddress where
48+ arbitrary = do
49+ s <- listOf1 (elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'])
50+ return $ unsafeEmailAddress (BSC.pack s) "example.com"
51+ -- FIXME: write the correct instance
52+ -- arbitrary = do
53+ -- m <- elements [1..32]
54+ -- n <- elements [1..32]
55+ -- let
56+ -- localGen = do
57+ -- let
58+ -- alphabets = T.pack $ ['a'..'Z']
59+ -- digits = T.pack $ ['0'..'9']
60+ -- alphaNum = alphabets <> digits
61+ -- symbols = "-!#$%&'*+-/=?^_`{|}~."
62+ -- localSym = alphaNum <> symbols
63+ -- encodeUtf8 <$> (replicateM m (elements localSym)
64+ -- `suchThat` (isRight . parseOnly localPart))
65+ -- local <- localGen
66+ -- -- no subdomains
67+ -- domain <- replicateM n (elements ['a'..'Z'])
68+ -- domainLiteral <- elements ["com", "travel", "net", "ru", "io"]
69+ -- unsafeEmailAddress <$> local <*> domain <> "." domainLiteral