Allow dotless email addresses in isEmail

digitallyinduced · Aug 30, 2020 · 1115ef4 · 1115ef4
1 parent 2d5451a
commit 1115ef4
Show file tree

Hide file tree

Showing 2 changed files with 8 additions and 5 deletions.
diff --git a/IHP/ValidationSupport/ValidateField.hs b/IHP/ValidationSupport/ValidateField.hs
@@ -215,13 +215,16 @@ isPhoneNumber text = Failure "is not a valid phone number (has to start with +,
 -- >>> isEmail "ॐ@मणिपद्मे.हूँ"
 -- Success
 --
--- >>> isEmail "marc@localhost" -- missing TLD
--- Failure "is not a valid email"
+-- >>> isEmail "marc@localhost" -- Although discouraged by ICANN, dotless TLDs are legal. See https://www.icann.org/news/announcement-2013-08-30-en
+-- Success
 --
 -- >>> isEmail "loremipsum"
 -- Failure "is not a valid email"
+--
+-- >>> isEmail "A@b@[email protected]"
+-- Failure "is not a valid email"
 isEmail :: Text -> ValidatorResult
-isEmail text | text =~ ("^[^ @]+@[^ @_+]+\\.[^ @_+-]+$" :: Text) = Success
+isEmail text | text =~ ("^[^ @]+@[^ @_+]+\\.?[^ @_+-]+$" :: Text) = Success
 isEmail text = Failure "is not a valid email"
 {-# INLINE isEmail #-}
 

diff --git a/Test/ValidationSupport/ValidateFieldSpec.hs b/Test/ValidationSupport/ValidateFieldSpec.hs
@@ -53,8 +53,8 @@ tests = do
         it "should allow Unicode characters" do
             isEmail "ॐ@मणिपद्मे.हूँ" `shouldBe` Success
 
-        it "should reject servers consisting of just TLD" do
-            isEmail "foo@localhost" `shouldSatisfy` isFailure
+        it "should allow dotless domains" do
+            isEmail "foo@localhost" `shouldBe` Success
 
     describe "The isInRange validator" do
         it "should handle trivial cases" do