From d5000773f6ecc09e9d644c7c4dcdcfe484de59d0 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Wed, 18 May 2022 18:34:26 +0200 Subject: [PATCH] Fix #1076: separate validators from UI and doctest them --- hackage-server.cabal | 1 + src/Distribution/Server/Util/Validators.hs | 43 ++--- .../Server/Util/Validators/Internal.hs | 153 ++++++++++++++++++ 3 files changed, 168 insertions(+), 29 deletions(-) create mode 100644 src/Distribution/Server/Util/Validators/Internal.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index af9413f62..d56c46c79 100644 --- a/hackage-server.cabal +++ b/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 diff --git a/src/Distribution/Server/Util/Validators.hs b/src/Distribution/Server/Util/Validators.hs index 2c247bbbf..1a16869a9 100644 --- a/src/Distribution/Server/Util/Validators.hs +++ b/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\" 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] diff --git a/src/Distribution/Server/Util/Validators/Internal.hs b/src/Distribution/Server/Util/Validators/Internal.hs new file mode 100644 index 000000000..67e7893bf --- /dev/null +++ b/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 "Emmanuel.Lauterbach@phantasy-promi.darknet.de" +-- Right () +-- +-- >>> validEmail "gerd.lauchkopf+spam@posteo.de" +-- 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" +-- 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\" style."