Fix #1076: separate validators from UI and doctest them

hackage-server.cabal

@@ -247,6 +247,7 @@ library lib-server
     Distribution.Server.Util.Parse
     Distribution.Server.Util.ServeTarball
     Distribution.Server.Util.Validators
+    Distribution.Server.Util.Validators.Internal
     -- [unused] Distribution.Server.Util.TarIndex
     Distribution.Server.Util.GZip
     Distribution.Server.Util.ContentType

src/Distribution/Server/Util/Validators.hs

@@ -4,41 +4,26 @@ module Distribution.Server.Util.Validators
   , guardValidLookingEmail
   ) where
 
-import           Data.Char (isSpace, isPrint)
-import qualified Data.Text as T
+import           Data.Text           (Text)
+import           Distribution.Pretty (prettyShow)
 
 import           Distribution.Server.Framework
-import           Distribution.Server.Users.Types (isValidUserNameChar)
+import           Distribution.Server.Util.Validators.Internal (validName, validUserName, validEmail)
 
-guardValidLookingName :: T.Text -> ServerPartE ()
-guardValidLookingName str = either errBadUserName return $ do
-  guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."
-  guard (T.all isPrint str)  ?! "Unexpected character in name, please use only printable Unicode characters."
+guardValidLookingName :: Text -> ServerPartE ()
+guardValidLookingName =
+  either (errBadUserName . prettyShow) return . validName
 
-guardValidLookingUserName :: T.Text -> ServerPartE ()
-guardValidLookingUserName str = either errBadRealName return $ do
-  guard (T.length str <= 50)    ?! "Sorry, we didn't expect login names to be longer than 50 characters."
-  guard (T.all isValidUserNameChar str) ?! "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols."
+guardValidLookingUserName :: Text -> ServerPartE ()
+guardValidLookingUserName =
+  either (errBadRealName . prettyShow) return . validUserName
 
 -- Make sure this roughly corresponds to the frontend validation in user-details-form.html.st
-guardValidLookingEmail :: T.Text -> ServerPartE ()
-guardValidLookingEmail str = either errBadEmail return $ do
-  guard (T.length str <= 100)     ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."
-  guard (T.all isPrint str)       ?! "Unexpected character in email address, please use only printable Unicode characters."
-  guard hasAtSomewhere            ?! "Oops, that doesn't look like an email address."
-  guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."
-  guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <[email protected]> style."
-  where
-    isAngle c = c == '<' || c == '>'
-    hasAtSomewhere = case T.span (/= '@') str of
-      (before, rest)
-        | Just (_, after) <- T.uncons rest ->
-          T.length before >= 1
-            && T.length after > 0
-            && not ('@' `T.elem` after)
-      _ -> False
+guardValidLookingEmail :: Text -> ServerPartE ()
+guardValidLookingEmail =
+  either (errBadEmail . prettyShow) return . validEmail
 
 errBadUserName, errBadRealName, errBadEmail :: String -> ServerPartE a
-errBadUserName err = errBadRequest "Problem with login name" [MText err]
-errBadRealName err = errBadRequest "Problem with name" [MText err]
+errBadUserName err = errBadRequest "Problem with login name"    [MText err]
+errBadRealName err = errBadRequest "Problem with name"          [MText err]
 errBadEmail    err = errBadRequest "Problem with email address" [MText err]

src/Distribution/Server/Util/Validators/Internal.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Purely functional version of "Distribution.Server.Util.Validators"
+-- for testing the validators.
+
+module Distribution.Server.Util.Validators.Internal where
+
+import           Control.Monad                   (unless)
+import           Control.Monad.Except            (MonadError(..))
+
+import           Data.Char                       (isSpace, isPrint)
+import           Data.Text                       (Text)
+import qualified Data.Text                       as T
+
+import           Distribution.Pretty             (Pretty(..))
+import           Distribution.Server.Users.Types (isValidUserNameChar)
+
+-- Set up doctest to deal with text literals.
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+
+-- | Basic sanity checking on names.
+--
+-- >>> validName "Innocent User"
+-- Right ()
+--
+-- >>> validName "Mr. X is the greatest super duper dude of all!"
+-- Right ()
+--
+-- >>> validName "I am also a developer, maintainer, blogger, for Haskell, Hackage, Cabal, Stackage"
+-- Left NameTooLong
+--
+-- >>> validName "My name has beeps \BEL, newlines \n, and \t tabs"
+-- Left NameNotPrintable
+--
+validName :: Text -> Either InvalidName ()
+validName str = do
+  unless (T.length str <= 70) $ throwError NameTooLong
+  unless (T.all isPrint str)  $ throwError NameNotPrintable
+
+-- | Errors produced by 'validName' check.
+
+data InvalidName
+  = NameTooLong       -- ^ More than 70 characters long.
+  | NameNotPrintable  -- ^ Contains unprintable characters.
+  deriving (Eq, Show)
+
+instance Pretty InvalidName where
+  pretty = \case
+    NameTooLong      -> "Sorry, we didn't expect names to be longer than 70 characters."
+    NameNotPrintable -> "Unexpected character in name, please use only printable Unicode characters."
+
+-- | Basic sanity checking on user names.
+--
+-- >>> validUserName "innocent_user_42"
+-- Right ()
+--
+-- >>> validUserName "mr_X_stretches_the_Limit_of_50_characters_01234567"
+-- Right ()
+--
+-- >>> validUserName "01234"
+-- Right ()
+--
+-- >>> validUserName "dashes-not-allowed"
+-- Left UserNameInvalidChar
+--
+-- >>> validUserName "questions_not_allowed?"
+-- Left UserNameInvalidChar
+--
+-- >>> validUserName "my_Ego_busts_the_Limit_of_50_characters_01234567890"
+-- Left UserNameTooLong
+--
+validUserName :: T.Text -> Either InvalidUserName ()
+validUserName str = do
+  unless (T.length str <= 50)            $ throwError UserNameTooLong
+  unless (T.all isValidUserNameChar str) $ throwError UserNameInvalidChar
+
+-- | Errors produced by 'validUserName' check.
+
+data InvalidUserName
+  = UserNameTooLong      -- ^ More than 50 characters long.
+  | UserNameInvalidChar  -- ^ Contains character not matching 'isValidUserNameChar'.
+  deriving (Eq, Show)
+
+instance Pretty InvalidUserName where
+  pretty = \case
+    UserNameTooLong     -> "Sorry, we didn't expect login names to be longer than 50 characters."
+    UserNameInvalidChar -> "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols."
+
+-- | Basic sanity checking in email.
+--
+-- >>> validEmail "[email protected]"
+-- Right ()
+--
+-- >>> validEmail "[email protected]"
+-- Right ()
+--
+-- >>> validEmail "Emmanuel.Lauterbachs.Cousin@mailrelay.tor.amazon-aws.bill-me.cold-fusion.bogus-domain.phantasy-promi.darknet.de"
+-- Left EmailTooLong
+--
+-- >>> validEmail "\BELlingcat@a\nonymous.\to"
+-- Left EmailNotPrintable
+--
+-- >>> validEmail "ich-im-aether"
+-- Left EmailBadFormat
+--
+-- >>> validEmail "ich@guuugle@kom"
+-- Left EmailBadFormat
+--
+-- >>> validEmail "Windows User @ Company . com"
+-- Left EmailHasSpace
+--
+-- >>> validEmail "Name<[email protected]>"
+-- Left EmailHasAngle
+--
+validEmail :: T.Text -> Either InvalidEmail ()
+validEmail str = do
+  unless (T.length str <= 100)     $ throwError EmailTooLong
+  unless (T.all isPrint str)       $ throwError EmailNotPrintable
+  unless hasAtSomewhere            $ throwError EmailBadFormat
+  unless (T.all (not.isSpace) str) $ throwError EmailHasSpace
+  unless (T.all (not.isAngle) str) $ throwError EmailHasAngle
+  where
+    isAngle c = c == '<' || c == '>'
+    hasAtSomewhere = case T.break (== '@') str of
+      (before, rest)
+        | Just (_, after) <- T.uncons rest ->
+            not $ or
+              [ T.null before
+              , T.null after
+              , '@' `T.elem` after
+              ]
+        | otherwise -> False
+
+-- | Errors produced by 'validEmail' check.
+
+data InvalidEmail
+  = EmailTooLong       -- ^ More than 100 characters long.
+  | EmailNotPrintable  -- ^ Contains unprintable characters.
+  | EmailBadFormat     -- ^ Doesn't have exactly one @ sign.
+  | EmailHasSpace      -- ^ Contains spaces.
+  | EmailHasAngle      -- ^ Contains angle brackets.
+  deriving (Eq, Show)
+
+instance Pretty InvalidEmail where
+  pretty = \case
+    EmailTooLong      -> "Sorry, we didn't expect email addresses to be longer than 100 characters."
+    EmailNotPrintable -> "Unexpected character in email address, please use only printable Unicode characters."
+    EmailBadFormat    -> "Oops, that doesn't look like an email address."
+    EmailHasSpace     -> "Oops, no spaces in email addresses please."
+    EmailHasAngle     -> "Please use just the email address, not \"name\" <[email protected]> style."