|
| 1 | +{-# LANGUAGE LambdaCase #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | + |
| 4 | +-- | Purely functional version of "Distribution.Server.Util.Validators" |
| 5 | +-- for testing the validators. |
| 6 | + |
| 7 | +module Distribution.Server.Util.Validators.Internal where |
| 8 | + |
| 9 | +import Control.Monad (unless) |
| 10 | +import Control.Monad.Except (MonadError(..)) |
| 11 | + |
| 12 | +import Data.Char (isSpace, isPrint) |
| 13 | +import Data.Text (Text) |
| 14 | +import qualified Data.Text as T |
| 15 | + |
| 16 | +import Distribution.Pretty (Pretty(..)) |
| 17 | +-- import Distribution.Server.Framework |
| 18 | +import Distribution.Server.Users.Types (isValidUserNameChar) |
| 19 | + |
| 20 | +-- Set up doctest to deal with text literals. |
| 21 | + |
| 22 | +-- $setup |
| 23 | +-- >>> :set -XOverloadedStrings |
| 24 | + |
| 25 | +-- | Basic sanity checking on names. |
| 26 | +-- |
| 27 | +-- >>> validName "Innocent User" |
| 28 | +-- Right () |
| 29 | +-- |
| 30 | +-- >>> validName "Mr. X is the greatest super duper dude of all!" |
| 31 | +-- Right () |
| 32 | +-- |
| 33 | +-- >>> validName "I am also a developer, maintainer, blogger, for Haskell, Hackage, Cabal, Stackage" |
| 34 | +-- Left NameTooLong |
| 35 | +-- |
| 36 | +-- >>> validName "My name has beeps \BEL, newlines \n, and \t tabs" |
| 37 | +-- Left NameNotPrintable |
| 38 | +-- |
| 39 | +validName :: Text -> Either InvalidName () |
| 40 | +validName str = do |
| 41 | + unless (T.length str <= 70) $ throwError NameTooLong |
| 42 | + unless (T.all isPrint str) $ throwError NameNotPrintable |
| 43 | + |
| 44 | +-- | Errors produced by 'validName' check. |
| 45 | + |
| 46 | +data InvalidName |
| 47 | + = NameTooLong -- ^ More than 70 characters long. |
| 48 | + | NameNotPrintable -- ^ Contains unprintable characters. |
| 49 | + deriving (Eq, Show) |
| 50 | + |
| 51 | +instance Pretty InvalidName where |
| 52 | + pretty = \case |
| 53 | + NameTooLong -> "Sorry, we didn't expect names to be longer than 70 characters." |
| 54 | + NameNotPrintable -> "Unexpected character in name, please use only printable Unicode characters." |
| 55 | + |
| 56 | +-- | Basic sanity checking on user names. |
| 57 | +-- |
| 58 | +-- >>> validUserName "innocent_user_42" |
| 59 | +-- Right () |
| 60 | +-- |
| 61 | +-- >>> validUserName "mr_X_stretches_the_Limit_of_50_characters_01234567" |
| 62 | +-- Right () |
| 63 | +-- |
| 64 | +-- >>> validUserName "01234" |
| 65 | +-- Right () |
| 66 | +-- |
| 67 | +-- >>> validUserName "dashes-not-allowed" |
| 68 | +-- Left UserNameInvalidChar |
| 69 | +-- |
| 70 | +-- >>> validUserName "questions_not_allowed?" |
| 71 | +-- Left UserNameInvalidChar |
| 72 | +-- |
| 73 | +-- >>> validUserName "my_Ego_busts_the_Limit_of_50_characters_01234567890" |
| 74 | +-- Left UserNameTooLong |
| 75 | +-- |
| 76 | +validUserName :: T.Text -> Either InvalidUserName () |
| 77 | +validUserName str = do |
| 78 | + unless (T.length str <= 50) $ throwError UserNameTooLong |
| 79 | + unless (T.all isValidUserNameChar str) $ throwError UserNameInvalidChar |
| 80 | + |
| 81 | +-- | Errors produced by 'validUserName' check. |
| 82 | + |
| 83 | +data InvalidUserName |
| 84 | + = UserNameTooLong -- ^ More than 50 characters long. |
| 85 | + | UserNameInvalidChar -- ^ Contains character not matching 'isValidUserNameChar'. |
| 86 | + deriving (Eq, Show) |
| 87 | + |
| 88 | +instance Pretty InvalidUserName where |
| 89 | + pretty = \case |
| 90 | + UserNameTooLong -> "Sorry, we didn't expect login names to be longer than 50 characters." |
| 91 | + UserNameInvalidChar -> "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols." |
| 92 | + |
| 93 | +-- | Basic sanity checking in email. |
| 94 | +-- |
| 95 | +-- >>> validEmail "[email protected]" |
| 96 | +-- Right () |
| 97 | +-- |
| 98 | +-- >>> validEmail "[email protected]" |
| 99 | +-- Right () |
| 100 | +-- |
| 101 | +-- >>> validEmail "Emmanuel.Lauterbachs.Cousin@mailrelay.tor.amazon-aws.bill-me.cold-fusion.bogus-domain.phantasy-promi.darknet.de" |
| 102 | +-- Left EmailTooLong |
| 103 | +-- |
| 104 | +-- >>> validEmail "\BELlingcat@a\nonymous.\to" |
| 105 | +-- Left EmailNotPrintable |
| 106 | +-- |
| 107 | +-- >>> validEmail "ich-im-aether" |
| 108 | +-- Left EmailBadFormat |
| 109 | +-- |
| 110 | +-- >>> validEmail "ich@guuugle@kom" |
| 111 | +-- Left EmailBadFormat |
| 112 | +-- |
| 113 | +-- >>> validEmail "Windows User @ Company . com" |
| 114 | +-- Left EmailHasSpace |
| 115 | +-- |
| 116 | +-- >>> validEmail "Name<[email protected]>" |
| 117 | +-- Left EmailHasAngle |
| 118 | +-- |
| 119 | +validEmail :: T.Text -> Either InvalidEmail () |
| 120 | +validEmail str = do |
| 121 | + unless (T.length str <= 100) $ throwError EmailTooLong |
| 122 | + unless (T.all isPrint str) $ throwError EmailNotPrintable |
| 123 | + unless hasAtSomewhere $ throwError EmailBadFormat |
| 124 | + unless (T.all (not.isSpace) str) $ throwError EmailHasSpace |
| 125 | + unless (T.all (not.isAngle) str) $ throwError EmailHasAngle |
| 126 | + where |
| 127 | + isAngle c = c == '<' || c == '>' |
| 128 | + hasAtSomewhere = case T.break (== '@') str of |
| 129 | + (before, rest) |
| 130 | + | Just (_, after) <- T.uncons rest -> |
| 131 | + not $ or |
| 132 | + [ T.null before |
| 133 | + , T.null after |
| 134 | + , '@' `T.elem` after |
| 135 | + ] |
| 136 | + | otherwise -> False |
| 137 | + |
| 138 | +-- | Errors produced by 'validEmail' check. |
| 139 | + |
| 140 | +data InvalidEmail |
| 141 | + = EmailTooLong -- ^ More than 100 characters long. |
| 142 | + | EmailNotPrintable -- ^ Contains unprintable characters. |
| 143 | + | EmailBadFormat -- ^ Doesn't have exactly one @ sign. |
| 144 | + | EmailHasSpace -- ^ Contains spaces. |
| 145 | + | EmailHasAngle -- ^ Contains angle brackets. |
| 146 | + deriving (Eq, Show) |
| 147 | + |
| 148 | +instance Pretty InvalidEmail where |
| 149 | + pretty = \case |
| 150 | + EmailTooLong -> "Sorry, we didn't expect email addresses to be longer than 100 characters." |
| 151 | + EmailNotPrintable -> "Unexpected character in email address, please use only printable Unicode characters." |
| 152 | + EmailBadFormat -> "Oops, that doesn't look like an email address." |
| 153 | + EmailHasSpace -> "Oops, no spaces in email addresses please." |
| 154 | + EmailHasAngle -> "Please use just the email address, not \"name\" <[email protected]> style." |
0 commit comments