packages feed

email-validate 2.0.1 → 2.1.0

raw patch · 4 files changed

+128/−83 lines, 4 files

Files

email-validate.cabal view
@@ -1,5 +1,5 @@ name:           email-validate
-version:        2.0.1
+version:        2.1.0
 license:        BSD3
 license-file:   LICENSE
 author:         George Pollard <porges@porg.es>
@@ -10,7 +10,7 @@ description:    Validating an email address string against RFC 5322
 build-type:     Simple
 stability:      experimental
-cabal-version:  >= 1.8
+cabal-version:  >= 1.10
 
 source-repository head
     type: git
@@ -19,29 +19,33 @@ source-repository this
     type: git
     location: git://github.com/Porges/email-validate-hs.git
-    tag: v2.0.0
+    tag: v2.1.0
 
 library
-    build-depends: base >= 4 && < 5
-                 , attoparsec >= 0.10.0
-                 , bytestring >= 0.9
-                 , ghc-prim
-    ghc-options: -O2
+    build-depends:
+        base >= 4 && < 5,
+        attoparsec >= 0.10.0,
+        bytestring >= 0.9,
+        ghc-prim
+    default-language: Haskell2010
+    default-extensions: DeriveGeneric, DeriveDataTypeable
     hs-source-dirs: src
-    exposed-modules: Text.Email.Validate
-                   , Text.Email.Parser
+    exposed-modules:
+        Text.Email.Validate,
+        Text.Email.Parser
 
 Test-Suite Main
     type: exitcode-stdio-1.0
     main-is: Main.hs
     hs-source-dirs: tests
-    test-module Test.Text.Email.Validate
     x-uses-tf: true
-    build-depends: base >= 4 && < 5
-                 , HUnit >= 1.2 && < 2
-                 , email-validate
-                 , QuickCheck >= 2.4
-                 , test-framework >= 0.4.1
-                 , test-framework-quickcheck2
-                 , test-framework-hunit
-                 , bytestring >= 0.9
+    default-language: Haskell2010
+    build-depends:
+        base >= 4 && < 5,
+        HUnit >= 1.2 && < 2,
+        email-validate,
+        QuickCheck >= 2.4,
+        test-framework >= 0.4.1,
+        test-framework-quickcheck2,
+        test-framework-hunit,
+        bytestring >= 0.9
src/Text/Email/Parser.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
 
 module Text.Email.Parser
-	(addrSpec
-	,localPart
-	,domainPart
-	,EmailAddress
-	,toByteString)
+    ( addrSpec
+    , localPart
+    , domainPart
+    , EmailAddress
+    , toByteString
+    )
 where
 
 import Control.Applicative
+import Control.Monad (void)
 
 import qualified Data.ByteString.Char8 as BS
 import Data.ByteString (ByteString)
 
-import Data.Char (chr)
 import Data.Attoparsec.ByteString.Char8
-import Data.Attoparsec.Combinator
 
 import Data.Data (Data, Typeable)
 import GHC.Generics (Generic)
@@ -24,93 +23,133 @@ 
 -- | Represents an email address.
 data EmailAddress = EmailAddress ByteString ByteString
-	deriving (Eq, Ord, Data, Typeable, Generic)
+    deriving (Eq, Ord, Data, Typeable, Generic)
 
 instance Show EmailAddress where
-	show = show . toByteString
+    show = show . toByteString
 
 instance Read EmailAddress where
-	readListPrec = Read.readListPrecDefault
-	readPrec = Read.parens (do
-		bs <- Read.readPrec
-		case parseOnly addrSpec bs of
-			Left  _ -> Read.pfail
-			Right a -> return a)
+    readsPrec _ s = go (parse addrSpec $ BS.pack s) where
+        go (Fail _ _ _) = []
+        go (Partial f)  = go (f BS.empty)
+        go (Done r adr) = [(adr, BS.unpack r)]
 
 -- | Converts an email address back to a ByteString
+toByteString :: EmailAddress -> ByteString
 toByteString (EmailAddress l d) = BS.concat [l, BS.singleton '@', d]
 
 -- | Extracts the local part of an email address.
 localPart :: EmailAddress -> ByteString
-localPart (EmailAddress local _) = local
+localPart (EmailAddress l _) = l
 
 -- | Extracts the domain part of an email address.
 domainPart :: EmailAddress -> ByteString
-domainPart (EmailAddress _ domain) = domain
+domainPart (EmailAddress _ d) = d
 
 -- | A parser for email addresses.
+addrSpec :: Parser EmailAddress
 addrSpec = do
-	localPart <- local
-	char '@'
-	domainPart <- domain
-	endOfInput
-	return (EmailAddress localPart domainPart)
+    l <- local
+    _ <- char '@'
+    d <- domain
+    return (EmailAddress l d)
 
+local :: Parser ByteString
 local = dottedAtoms
+
+domain :: Parser ByteString
 domain = dottedAtoms <|> domainLiteral
 
+dottedAtoms :: Parser ByteString
 dottedAtoms = BS.intercalate (BS.singleton '.') <$>
-	(optional cfws *> (atom <|> quotedString) <* optional cfws)	`sepBy1` (char '.')
+        between1 (optional cfws) (atom <|> quotedString) `sepBy1` char '.'
+
+atom :: Parser ByteString
 atom = takeWhile1 isAtomText
 
+isAtomText :: Char -> Bool
 isAtomText x = isAlphaNum x || inClass "!#$%&'*+/=?^_`{|}~-" x
 
-domainLiteral = (BS.cons '[' . flip BS.snoc ']' . BS.concat) <$> (between (optional cfws *> char '[') (char ']' <* optional cfws) $
-	many (optional fws >> takeWhile1 isDomainText) <* optional fws)
+domainLiteral :: Parser ByteString
+domainLiteral =
+    (BS.cons '[' . flip BS.snoc ']' . BS.concat) <$>
+        between (optional cfws *> char '[') (char ']' <* optional cfws)
+            (many (optional fws >> takeWhile1 isDomainText) <* optional fws)
+
+isDomainText :: Char -> Bool
 isDomainText x = inClass "\33-\90\94-\126" x || isObsNoWsCtl x
 
-quotedString = (\x -> BS.concat $ [BS.singleton '"', BS.concat x, BS.singleton '"']) <$> (between (char '"') (char '"') $
-	many (optional fws >> quotedContent) <* optional fws)
+quotedString :: Parser ByteString
+quotedString =
+    (\x -> BS.concat [BS.singleton '"', BS.concat x, BS.singleton '"']) <$>
+        between (char '"') (char '"')
+            (many (optional fws >> quotedContent) <* optional fws)
 
+quotedContent :: Parser ByteString
 quotedContent = takeWhile1 isQuotedText <|> quotedPair
+
+isQuotedText :: Char -> Bool
 isQuotedText x = inClass "\33\35-\91\93-\126" x || isObsNoWsCtl x
 
+quotedPair :: Parser ByteString
 quotedPair = (BS.cons '\\' . BS.singleton) <$> (char '\\' *> (vchar <|> wsp <|> lf <|> cr <|> obsNoWsCtl <|> nullChar))
 
-cfws = ignore $ many (comment <|> fws)
+cfws :: Parser ()
+cfws = skipMany (comment <|> fws)
 
 fws :: Parser ()
-fws = ignore $
-	ignore (wsp1 >> optional (crlf >> wsp1))
-	<|> ignore (many1 (crlf >> wsp1))
-
-ignore :: Parser a -> Parser ()
-ignore x = x >> return ()
+fws = void (wsp1 >> optional (crlf >> wsp1)) <|> (skipMany1 (crlf >> wsp1))
 
+between :: Applicative f => f l -> f r -> f a -> f a
 between l r x = l *> x <* r
 
+between1 :: Applicative f => f lr -> f a -> f a
+between1 lr x = lr *> x <* lr
+
 comment :: Parser ()
-comment = ignore ((between (char '(') (char ')') $
-	many (ignore commentContent <|> fws)))
+comment = between (char '(') (char ')') $ skipMany (void commentContent <|> fws)
 
-commentContent = skipWhile1 isCommentText <|> ignore quotedPair <|> comment
+commentContent :: Parser ()
+commentContent = skipWhile1 isCommentText <|> void quotedPair <|> comment
+
+isCommentText :: Char -> Bool
 isCommentText x = inClass "\33-\39\42-\91\93-\126" x || isObsNoWsCtl x
 
+nullChar :: Parser Char
 nullChar = char '\0'
 
+skipWhile1 :: (Char -> Bool) -> Parser()
 skipWhile1 x = satisfy x >> skipWhile x
 
+wsp1 :: Parser ()
 wsp1 = skipWhile1 isWsp
+
+wsp :: Parser Char
 wsp = satisfy isWsp
+
+isWsp :: Char -> Bool
 isWsp x = x == ' ' || x == '\t'
 
+isAlphaNum :: Char -> Bool
 isAlphaNum x = isDigit x || isAlpha_ascii x
+
+cr :: Parser Char
 cr = char '\r'
+
+lf :: Parser Char
 lf = char '\n'
-crlf = cr >> lf >> return ()
 
+crlf :: Parser ()
+crlf = void $ cr >> lf
+
+isVchar :: Char -> Bool
 isVchar = inClass "\x21-\x7e"
+
+vchar :: Parser Char
 vchar = satisfy isVchar
 
+isObsNoWsCtl :: Char -> Bool
 isObsNoWsCtl = inClass "\1-\8\11-\12\14-\31\127"
-obsNoWsCtl = satisfy isObsNoWsCtl+
+obsNoWsCtl :: Parser Char
+obsNoWsCtl = satisfy isObsNoWsCtl
src/Text/Email/Validate.hs view
@@ -1,26 +1,25 @@ module Text.Email.Validate
-	(isValid
-	,validate
-	,emailAddress
-	,canonicalizeEmail 
-	,EmailAddress -- re-exported
-	,localPart
-	,domainPart
-	,toByteString) 
+	( isValid
+	, validate
+	, emailAddress
+	, canonicalizeEmail
+	, EmailAddress -- re-exported
+	, localPart
+	, domainPart
+	, toByteString
+	)
 where
 
-import qualified Data.ByteString.Char8 as BS
+import Control.Applicative ((<*))
+
 import Data.ByteString (ByteString)
-import Data.Attoparsec (parseOnly)
+import Data.Attoparsec.ByteString (parseOnly, endOfInput)
 
-import Text.Email.Parser
+import Text.Email.Parser (EmailAddress, toByteString, addrSpec, localPart, domainPart)
 
 -- | Smart constructor for an email address
 emailAddress :: ByteString -> Maybe EmailAddress
-emailAddress x =
-	case validate x of
-		Left _  -> Nothing
-		Right em -> Just em
+emailAddress = either (const Nothing) Just . validate
 
 -- | Checks that an email is valid and returns a version of it
 --   where comments and whitespace have been removed.
@@ -30,10 +29,9 @@ -- | Validates whether a particular string is an email address
 --   according to RFC5322.
 isValid :: ByteString -> Bool
-isValid x = let result = validate x in
-	either (const False) (const True) result
+isValid = either (const False) (const True) . validate
 
 -- | If you want to find out *why* a particular string is not
 --   an email address, use this.
 validate :: ByteString -> Either String EmailAddress
-validate = parseOnly addrSpec
+validate = parseOnly (addrSpec <* endOfInput)
tests/Main.hs view
@@ -1,6 +1,6 @@ module Main where
 
-import Data.Maybe (catMaybes)
+
 import Text.Email.Validate
 import Test.HUnit
 
@@ -26,7 +26,7 @@                 testProperty "doubleCanonicalize" prop_doubleCanonicalize
                 ],
         testGroup "Unit tests Text.Email.Validate" $ flip concatMap units
-            (\(em, valid, why) -> let email = BS.pack em
+            (\(em, valid, _) -> let email = BS.pack em
                 in
                     [
                     testCase ("doubleCanonicalize '" ++ em ++ "'") (True @=? case emailAddress email of { Nothing -> True; Just ok -> prop_doubleCanonicalize ok }),
@@ -40,25 +40,29 @@ instance Arbitrary EmailAddress where
     arbitrary = do
         local <- suchThat arbitrary (\x -> isEmail x (BS.pack "example.com"))
-        domain <- suchThat arbitrary (\x -> isEmail (BS.pack "example") x)
+        domain <- suchThat arbitrary (isEmail (BS.pack "example"))
         let email = makeEmailLike local domain
         let (Just result) = emailAddress email
         return result
 
+isEmail :: ByteString -> ByteString -> Bool
 isEmail l d = isValid (makeEmailLike l d)
 
+makeEmailLike :: ByteString -> ByteString -> ByteString
 makeEmailLike l d = BS.concat [l, BS.singleton '@', d]
 
+prop_doubleCanonicalize :: EmailAddress -> Bool
 prop_doubleCanonicalize email =  Just email == emailAddress (toByteString email)
 
 prop_showLikeByteString :: EmailAddress -> Bool
 prop_showLikeByteString email = show (toByteString email) == show email
 
 prop_showAndReadBack :: EmailAddress -> Bool
-prop_showAndReadBack email = read (show email) == email
+prop_showAndReadBack email = read (read (show email)) == email
 
 --unitTest (x, y, z) = if not (isValid (BS.pack x) == y) then "" else (x ++" became "++ (case emailAddress (BS.pack x) of {Nothing -> "fail"; Just em -> show em}) ++": Should be "++show y ++", got "++show (not y)++"\n\t"++z++"\n")
 
+units :: [(String, Bool, String)]
 units = [
     ("first.last@example.com", True, ""),
     ("1234567890123456789012345678901234567890123456789012345678901234@example.com", True, ""),
@@ -288,4 +292,4 @@     --("first.last@com", False, "Mail host must be second- or lower level"),
     --("first.last@-xample.com", False, "Label can\'t begin with a hyphen"),
     --("first.last@exampl-.com", False, "Label can\'t end with a hyphen"),
-    ]+    ]