diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,20 @@ # Changelog for password +## 2.1.0.0 + +- A new `Validate` module has been added to dictate policies that passwords + should adhere to and the necessary API to verify that they do. + [#26](https://github.com/cdepillabout/password/pull/26) + Huge thanks to [@HirotoShioi](https://github.com/HirotoShioi) for picking + up the task of adding this functionality and doing most of the groundwork. + [#27](https://github.com/cdepillabout/password/pull/27) + Thanks to Felix Paulusma ([@Vlix](https://github.com/Vlix)) for finishing + up the API and documentation. + ## 2.0.1.1 -- Fixed cross-module links in the haddocks - [#19](https://github.com/cdepillabout/password/pull/19). Thanks to +- Fixed cross-module links in the haddocks. + [#19](https://github.com/cdepillabout/password/pull/19) Thanks to [@TristanCacqueray](https://github.com/TristanCacqueray) for fixing this. ## 2.0.1.0 @@ -11,8 +22,7 @@ - Switched checking hashes to using `Data.ByteArray.constEq`, instead of the default `(==)` method of `ByteString`. This is to make it more secure against timing attacks. [#16](https://github.com/cdepillabout/password/pull/16) - Thanks to maralorn ([@maralorn](https://github.com/maralorn)) for bringing - this up. + Thanks to [@maralorn](https://github.com/maralorn) for bringing this up. ## 2.0.0.1 diff --git a/password.cabal b/password.cabal --- a/password.cabal +++ b/password.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: password -version: 2.0.1.1 +version: 2.1.0.0 category: Data synopsis: Hashing and checking of passwords description: A library providing functionality for working with plain-text and hashed passwords with different types of algorithms. @@ -36,6 +36,7 @@ Data.Password.Bcrypt Data.Password.PBKDF2 Data.Password.Scrypt + Data.Password.Validate other-modules: Paths_password Data.Password.Internal @@ -43,8 +44,9 @@ base >= 4.9 && < 5 , base64 >= 0.3 && < 0.5 , bytestring >= 0.10.8.1 && < 0.11 - , cryptonite >= 0.15.1 && < 0.27 + , cryptonite >= 0.15.1 && < 0.28 , memory >= 0.14 && < 0.16 + , template-haskell , text >= 1.2.2 && < 1.3 ghc-options: -Wall @@ -84,6 +86,8 @@ , Internal , PBKDF2 , Scrypt + , TestPolicy + , Validate , Paths_password ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N @@ -96,6 +100,7 @@ , quickcheck-instances , scrypt , tasty + , tasty-hunit , tasty-quickcheck , text default-language: diff --git a/src/Data/Password/Internal.hs b/src/Data/Password/Internal.hs --- a/src/Data/Password/Internal.hs +++ b/src/Data/Password/Internal.hs @@ -141,4 +141,3 @@ showT :: forall a. Show a => a -> Text showT = T.pack . show {-# INLINE showT #-} - diff --git a/src/Data/Password/Validate.hs b/src/Data/Password/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Password/Validate.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Data.Password.Validate +Copyright : (c) Hiroto Shioi, 2020; Felix Paulusma, 2020 +License : BSD-style (see LICENSE file) +Maintainer : cdep.illabout@gmail.com +Stability : experimental +Portability : POSIX + += Password Validation + +It is common for passwords to have a set of requirements. For example, +a password might have to contain at least a certain amount of characters +that consist of uppercase and lowercase alphabetic characters combined with +numbers and/or other special characters. + +This module provides an API which enables you to set up your own +'PasswordPolicy' to validate the format of 'Password's. + +== Password Policies + +The most important part is to have a valid and robust 'PasswordPolicy'. + +A 'defaultPasswordPolicy_' is provided to quickly set up a "good-enough" +validation of passwords, but you can also adjust it, or just create your +own. + +Just remember that a 'PasswordPolicy' must be validated first to make +sure it is actually a 'ValidPasswordPolicy'. Otherwise, you'd never be +able to validate any given 'Password's. + += Example usage + +So let's say we're fine with the default policy, which requires the +password to be between 8-64 characters, and have at least one lowercase, +one uppercase and one digit character, then our function would look like +the following: + +@ +myValidateFunc :: 'Password' -> Bool +myValidateFunc = 'isValidPassword' 'defaultPasswordPolicy_' +@ + +== Custom policies + +But, for example, if you'd like to enforce that a 'Password' includes +at least one special character, and be at least 12 characters long, +you'll have to make your own 'PasswordPolicy'. + +@ +customPolicy :: 'PasswordPolicy' +customPolicy = + 'defaultPasswordPolicy' + { minimumLength = 12 + , specialChars = 1 + } +@ + +This custom policy will then have to be validated first, so it can be +used to validate 'Password's further on. + +== Template Haskell + +The easiest way to validate a custom 'PasswordPolicy' is by using a +Template Haskell splice. +Just turn on the @\{\-\# LANGUAGE TemplateHaskell \#\-\}@ pragma, pass your +policy to 'validatePasswordPolicyTH', surround it by @\$(...)@ and if +it compiles it will be a 'ValidPasswordPolicy'. + +@ +{-\# LANGUAGE TemplateHaskell \#-} +customValidPolicy :: 'ValidPasswordPolicy' +customValidPolicy = $('validatePasswordPolicyTH' customPolicy) +@ + +__NB: any custom 'CharSetPredicate' will be ignored by 'validatePasswordPolicyTH'__ +__and replaced with the 'defaultCharSetPredicate'.__ +So if you want to use your own 'CharSetPredicate', you won't be able +to validate your policy using 'validatePasswordPolicyTH'. Most users, +however, will find 'defaultCharSetPredicate' to be sufficient. + +== At runtime + +Another way of validating your custom policy is 'validatePasswordPolicy'. +In an application, this might be implemented in the following way. + +@ +main :: IO () +main = + case ('validatePasswordPolicy' customPolicy) of + Left reasons -> error $ show reasons + Right validPolicy -> app \`runReaderT\` validPolicy + +customValidateFunc :: 'Password' -> ReaderT 'ValidPasswordPolicy' IO Bool +customValidateFunc pwd = do + policy <- ask + return $ 'isValidPassword' policy pwd +@ + +== Let's get dangerous + +Or, if you like living on the edge, you could also just match on 'Right'. +I hope you're certain your policy is valid, though. So please have at least +a unit test to verify that passing your 'PasswordPolicy' to +'validatePasswordPolicy' actually returns a 'Right'. + +@ +Right validPolicy = 'validatePasswordPolicy' customPolicy + +customValidateFunc :: 'Password' -> Bool +customValidateFunc = 'isValidPassword' validPolicy +@ + +-} + +module Data.Password.Validate + ( -- * Validating passwords + -- + -- | + -- The main function of this module is probably 'isValidPassword', + -- as it is simple and straightforward. + -- + -- Though if you'd want to know why a 'Password' failed to validate, + -- because you'd maybe like to communicate those 'InvalidReason's + -- back to the user, 'validatePassword' is here to help you out. + validatePassword, + isValidPassword, + ValidationResult(..), + -- ** Password Policy + -- + -- | + -- A 'PasswordPolicy' has to be validated before it can be used to validate a + -- 'Password'. + -- This is done using 'validatePasswordPolicy' or 'validatePasswordPolicyTH'. + -- + -- Next to the obvious lower and upper bounds for the length of a 'Password', + -- a 'PasswordPolicy' can dictate how many lowercase letters, uppercase letters, + -- digits and/or special characters are minimally required to be used in the + -- 'Password' to be considered a valid 'Password'. + -- + -- An observant user might have also seen that a 'PasswordPolicy' includes a + -- 'CharSetPredicate'. Very few users will want to change this from the + -- 'defaultCharSetPredicate', since this includes all non-control ASCII characters. + -- + -- If, for some reason, you'd like to accept more characters (e.g. é, ø, か, 事) + -- or maybe you want to only allow alpha-numeric characters, 'charSetPredicate' is + -- the place to do so. + validatePasswordPolicy, + validatePasswordPolicyTH, + PasswordPolicy (..), + ValidPasswordPolicy, + fromValidPasswordPolicy, + defaultPasswordPolicy, + defaultPasswordPolicy_, + CharSetPredicate(..), + defaultCharSetPredicate, + InvalidReason (..), + InvalidPolicyReason(..), + CharacterCategory(..), + MinimumLength, + MaximumLength, + ProvidedLength, + MinimumAmount, + ProvidedAmount, + -- * For internal use + -- + -- | These are used in the test suite. You should not need these. + -- + -- These are basically internal functions and as such have NO guarantee (__NONE__) + -- to be consistent between releases. + defaultCharSet, + validateCharSetPredicate, + categoryToPredicate, + isSpecial, + allButCSP + ) where + +import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit, ord) +import Data.Function (on) +import Data.List (foldl') + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH (Exp, Q, appE) +import Language.Haskell.TH.Syntax (Lift (..)) + +import Data.Password.Internal (Password (..)) + +-- $setup +-- >>> :set -XOverloadedStrings +-- +-- Import needed libraries. +-- +-- >>> import Data.Password + +-- | Set of policies used to validate a 'Password'. +-- +-- When defining your own 'PasswordPolicy', please keep in mind that: +-- +-- * The value of 'maximumLength' must be bigger than 0 +-- * The value of 'maximumLength' must be bigger than 'minimumLength' +-- * If any other field has a negative value (e.g. 'lowercaseChars'), it will be defaulted to 0 +-- * The total sum of all character category values (i.e. all fields ending in @-Chars@) +-- must not be larger than the value of 'maximumLength'. +-- * The provided 'CharSetPredicate' needs to allow at least one of the characters in the +-- categories which require more than 0 characters. (e.g. if 'lowercaseChars' is > 0, +-- the 'charSetPredicate' must allow at least one of the characters in @[\'a\'..\'z\']@) +-- +-- or else the validation functions will return one or more 'InvalidPolicyReason's. +-- +-- If you're unsure of what to do, please use the default: 'defaultPasswordPolicy_' +-- +-- @since 2.1.0.0 +data PasswordPolicy = PasswordPolicy + { minimumLength :: !Int + -- ^ Required password minimum length + , maximumLength :: !Int + -- ^ Required password maximum length + , uppercaseChars :: !Int + -- ^ Required number of upper-case characters + , lowercaseChars :: !Int + -- ^ Required number of lower-case characters + , specialChars :: !Int + -- ^ Required number of special characters + , digitChars :: !Int + -- ^ Required number of ASCII-digit characters + , charSetPredicate :: CharSetPredicate + -- ^ Which characters are acceptable for use in passwords (cf. 'defaultCharSetPredicate') + } + +-- NB: KEEP THIS THE SAME ORDER AS THE PasswordPolicy FIELDS! +-- OTHERWISE THE 'validatePasswordPolicyTH' FUNCTION WILL BREAK. + +-- @since 2.1.0.0 +-- | All 'Int' fields of the 'PasswordPolicy' in a row +allButCSP :: PasswordPolicy -> [Int] +allButCSP PasswordPolicy{..} = + [ minimumLength + , maximumLength + , uppercaseChars + , lowercaseChars + , specialChars + , digitChars + ] + +-- | N.B. This will not check equality on the 'charSetPredicate' +instance Eq PasswordPolicy where + (==) = go `on` allButCSP + where + go a b = and $ zipWith (==) a b + +-- | N.B. This will not check order on the 'charSetPredicate' +instance Ord PasswordPolicy where + compare = go `on` allButCSP + where + go a b = check $ zipWith compare a b + check [] = EQ + check (EQ : xs) = check xs + check (x : _) = x + +instance Show PasswordPolicy where + show PasswordPolicy{..} = mconcat + [ "PasswordPolicy {" + , "minimumLength = ", show minimumLength + , ", maximumLength = ", show maximumLength + , ", uppercaseChars = ", show uppercaseChars + , ", lowercaseChars = ", show lowercaseChars + , ", specialChars = ", show specialChars + , ", digitChars = ", show digitChars + , ", charSetPredicate = }" + ] + +-- | A 'PasswordPolicy' that has been checked to be valid +-- +-- @since 2.1.0.0 +newtype ValidPasswordPolicy = VPP + { fromValidPasswordPolicy :: PasswordPolicy + -- ^ + -- In case you'd want to retrieve the 'PasswordPolicy' + -- from the 'ValidPasswordPolicy' + -- + -- @since 2.1.0.0 + } deriving (Eq, Ord, Show) + +-- | Default value for the 'PasswordPolicy'. +-- +-- Enforces that a password must be between 8-64 characters long and +-- have at least one uppercase letter, one lowercase letter and one digit, +-- though can easily be adjusted by using record update syntax: +-- +-- @ +-- myPolicy = defaultPasswordPolicy{ specialChars = 1 } +-- @ +-- +-- This policy on it's own is guaranteed to be valid. Any changes made to +-- it might result in 'validatePasswordPolicy' returning one or more +-- 'InvalidPolicyReason's. +-- +-- >>> defaultPasswordPolicy +-- PasswordPolicy {minimumLength = 8, maximumLength = 64, uppercaseChars = 1, lowercaseChars = 1, specialChars = 0, digitChars = 1, charSetPredicate = } +-- +-- @since 2.1.0.0 +defaultPasswordPolicy :: PasswordPolicy +defaultPasswordPolicy = PasswordPolicy + { minimumLength = 8, + maximumLength = 64, + uppercaseChars = 1, + lowercaseChars = 1, + specialChars = 0, + digitChars = 1, + charSetPredicate = defaultCharSetPredicate + } + +-- | Unchangeable 'defaultPasswordPolicy', but guaranteed to be valid. +-- +-- @since 2.1.0.0 +defaultPasswordPolicy_ :: ValidPasswordPolicy +defaultPasswordPolicy_ = VPP defaultPasswordPolicy + +-- | Predicate which defines the characters that can be used for a password. +-- +-- @since 2.1.0.0 +newtype CharSetPredicate = CharSetPredicate + { getCharSetPredicate :: Char -> Bool + } + +-- | The default character set consists of uppercase and lowercase letters, numbers, +-- and special characters from the @ASCII@ character set. +-- (i.e. everything from the @ASCII@ set except the control characters) +-- +-- @since 2.1.0.0 +defaultCharSetPredicate :: CharSetPredicate +defaultCharSetPredicate = CharSetPredicate $ \c -> ord c >= 32 && ord c <= 126 +{-# INLINE defaultCharSetPredicate #-} + +-- @since 2.1.0.0 +-- | Check if given 'Char' is a special character. +-- (i.e. any non-alphanumeric non-control ASCII character) +isSpecial :: Char -> Bool +isSpecial = \c -> + isDefault c && not (isAsciiUpper c || isAsciiLower c || isDigit c) + where + CharSetPredicate isDefault = defaultCharSetPredicate + +-- | Character categories +-- +-- @since 2.1.0.0 +data CharacterCategory + = Uppercase + -- ^ Uppercase letters + | Lowercase + -- ^ Lowercase letters + | Special + -- ^ Special characters + | Digit + -- ^ ASCII digits + deriving (Eq, Ord, Show) + +-- @since 2.1.0.0 +-- | Convert a 'CharacterCategory' into its associated predicate function +categoryToPredicate :: CharacterCategory -> (Char -> Bool) +categoryToPredicate = \case + Uppercase -> isAsciiUpper + Lowercase -> isAsciiLower + Special -> isSpecial + Digit -> isDigit + +type MinimumLength = Int +type MaximumLength = Int +type ProvidedLength = Int +type MinimumAmount = Int +type ProvidedAmount = Int + +-- | Possible reasons for a 'Password' to be invalid. +-- +-- @since 2.1.0.0 +data InvalidReason + = PasswordTooShort !MinimumLength !ProvidedLength + -- ^ Length of 'Password' is too short. + | PasswordTooLong !MaximumLength !ProvidedLength + -- ^ Length of 'Password' is too long. + | NotEnoughReqChars !CharacterCategory !MinimumAmount !ProvidedAmount + -- ^ 'Password' does not contain required number of characters. + | InvalidCharacters !Text + -- ^ 'Password' contains characters that cannot be used + deriving (Eq, Ord, Show) + +-- | Possible reasons for a 'PasswordPolicy' to be invalid +-- +-- @since 2.1.0.0 +data InvalidPolicyReason + = InvalidLength !MinimumLength !MaximumLength + -- ^ Value of 'minimumLength' is bigger than 'maximumLength' + -- + -- @InvalidLength minimumLength maximumLength@ + | MaxLengthBelowZero !MaximumLength + -- ^ Value of 'maximumLength' is zero or less + -- + -- @MaxLengthBelowZero maximumLength@ + | CategoryAmountsAboveMaxLength !MaximumLength !Int + -- ^ The total of the character category amount requirements are + -- higher than the maximum length of the password. (i.e. the 'Int' signifies + -- the total of 'lowercaseChars' + 'uppercaseChars' + 'digitChars' + 'specialChars') + -- + -- @CategoryAmountsAboveMaxLength maximumLength totalRequiredChars@ + | InvalidCharSetPredicate !CharacterCategory !MinimumAmount + -- ^ 'charSetPredicate' does not return 'True' for a 'CharacterCategory' that + -- requires at least 'MinimumAmount' characters in the password + deriving (Eq, Ord, Show) + +-- | Result of validating a 'Password'. +-- +-- @since 2.1.0.0 +data ValidationResult = ValidPassword | InvalidPassword [InvalidReason] + deriving (Eq, Show) + +-- | This function is equivalent to: +-- +-- @'validatePassword' policy password == 'ValidPassword'@ +-- +-- >>> let pass = mkPassword "This_Is_Valid_PassWord1234" +-- >>> isValidPassword defaultPasswordPolicy_ pass +-- True +-- +-- @since 2.1.0.0 +isValidPassword :: ValidPasswordPolicy -> Password -> Bool +isValidPassword policy pass = validatePassword policy pass == ValidPassword +{-# INLINE isValidPassword #-} + +-- | Checks if a given 'Password' adheres to the provided 'ValidPasswordPolicy'. +-- +-- In case of an invalid password, returns the reasons why it wasn't valid. +-- +-- >>> let pass = mkPassword "This_Is_Valid_Password1234" +-- >>> validatePassword defaultPasswordPolicy_ pass +-- ValidPassword +-- +-- @since 2.1.0.0 +validatePassword :: ValidPasswordPolicy -> Password -> ValidationResult +validatePassword (VPP PasswordPolicy{..}) (Password password) = + case validationFailures of + [] -> ValidPassword + _:_ -> InvalidPassword validationFailures + + where + validationFailures = mconcat + [ isTooShort + , isTooLong + , isUsingValidCharacters + , hasRequiredChar uppercaseChars Uppercase + , hasRequiredChar lowercaseChars Lowercase + , hasRequiredChar specialChars Special + , hasRequiredChar digitChars Digit + ] + len = T.length password + isTooLong = [PasswordTooLong maximumLength len | len > maximumLength] + isTooShort = [PasswordTooShort minimumLength len | len < minimumLength] + + CharSetPredicate predicate = charSetPredicate + isUsingValidCharacters :: [InvalidReason] + isUsingValidCharacters = + let filteredText = T.filter (not . predicate) password + in [InvalidCharacters filteredText | not $ T.null filteredText] + hasRequiredChar :: Int -> CharacterCategory -> [InvalidReason] + hasRequiredChar requiredCharNum characterCategory + | requiredCharNum <= 0 = [] + | otherwise = + let p = categoryToPredicate characterCategory + actualRequiredCharNum = T.length $ T.filter p password + in [ NotEnoughReqChars characterCategory requiredCharNum actualRequiredCharNum + | actualRequiredCharNum < requiredCharNum + ] + +-- | Validate 'CharSetPredicate' to return 'True' on at least one of the characters +-- that is required. +-- +-- For instance, if 'PasswordPolicy' states that the password requires at least +-- one uppercase letter, then 'CharSetPredicate' should return True on at least +-- one uppercase letter. +validateCharSetPredicate :: PasswordPolicy -> [InvalidPolicyReason] +validateCharSetPredicate PasswordPolicy{..} = + let charSets = accumulateCharSet + [ (uppercaseChars, Uppercase) + , (lowercaseChars, Lowercase) + , (specialChars, Special) + , (digitChars, Digit) + ] + in concatMap checkPredicate charSets + where + CharSetPredicate predicate = charSetPredicate + checkPredicate :: (Int, CharacterCategory, String) -> [InvalidPolicyReason] + checkPredicate (num, category, sets) = + [InvalidCharSetPredicate category num | not $ any predicate sets] + accumulateCharSet :: [(Int, CharacterCategory)] -> [(Int, CharacterCategory, String)] + accumulateCharSet xs = + [ (num, c, categoryToString c) + | (num, c) <- xs + , num > 0 + ] + categoryToString :: CharacterCategory -> String + categoryToString category = filter (categoryToPredicate category) defaultCharSet + +-- | Template Haskell validation function for 'PasswordPolicy's. +-- +-- @ +-- {-\# LANGUAGE TemplateHaskell \#-} +-- myPolicy :: 'PasswordPolicy' +-- myPolicy = 'defaultPasswordPolicy'{ specialChars = 1 } +-- +-- myValidPolicy :: 'ValidPasswordPolicy' +-- myValidPolicy = $('validatePasswordPolicyTH' myPolicy) +-- @ +-- +-- For technical reasons, the 'charSetPredicate' field is ignored and the +-- 'defaultCharSetPredicate' is used. If, for any reason, you do need to use a +-- custom 'CharSetPredicate', please use 'validatePasswordPolicy' and either handle +-- the failure case at runtime and/or use a unit test to make sure your policy is valid. +-- +-- @since 2.1.0.0 +validatePasswordPolicyTH :: PasswordPolicy -> Q Exp +validatePasswordPolicyTH pp = + either (fail . showReasons) go $ validatePasswordPolicy withDefault + where + withDefault = pp{charSetPredicate = defaultCharSetPredicate} + showReasons rs = "Bad password policy: " ++ show rs + go _ = [|VPP|] `appE` newPP + allButCSPQ = lift <$> allButCSP withDefault + newPP = foldl' appE [|PasswordPolicy|] allButCSPQ `appE` [|defaultCharSetPredicate|] + +-- | Verifies that a 'PasswordPolicy' is valid and converts it into a 'ValidPasswordPolicy'. +-- +-- >>> validatePasswordPolicy defaultPasswordPolicy +-- Right (...) +-- +-- @since 2.1.0.0 +validatePasswordPolicy :: PasswordPolicy -> Either [InvalidPolicyReason] ValidPasswordPolicy +validatePasswordPolicy policy@PasswordPolicy{..} = + case allReasons of + [] -> Right $ VPP policy + _ -> Left allReasons + where + allReasons = mconcat [validMaxLength, validLength, validCategoryAmount, validPredicate] + validLength, validMaxLength, validCategoryAmount, validPredicate :: [InvalidPolicyReason] + validLength = + [InvalidLength minimumLength maximumLength | minimumLength > maximumLength] + validMaxLength = + [MaxLengthBelowZero maximumLength | maximumLength <= 0] + validCategoryAmount = + -- We don't report this reason if the maximumLength is already invalid + [CategoryAmountsAboveMaxLength maximumLength total | total > maximumLength, maximumLength > 0] + where + capToZero = max 0 + total = sum $ capToZero <$> [lowercaseChars, uppercaseChars, digitChars, specialChars] + validPredicate = validateCharSetPredicate policy + +-- @since 2.1.0.0 +-- | Default character set +-- +-- Should be all non-control characters in the ASCII character set. +defaultCharSet :: String +defaultCharSet = chr <$> [32 .. 126] diff --git a/test/tasty/Spec.hs b/test/tasty/Spec.hs --- a/test/tasty/Spec.hs +++ b/test/tasty/Spec.hs @@ -8,6 +8,7 @@ import Bcrypt import PBKDF2 import Scrypt +import Validate main :: IO () main = defaultMain $ localOption (NumThreads 1) $ @@ -18,4 +19,5 @@ , testBcrypt , testPBKDF2 , testScrypt + , testValidate ] diff --git a/test/tasty/TestPolicy.hs b/test/tasty/TestPolicy.hs new file mode 100644 --- /dev/null +++ b/test/tasty/TestPolicy.hs @@ -0,0 +1,21 @@ +module TestPolicy where + +import Data.Password.Validate ( + PasswordPolicy (..), + defaultPasswordPolicy, + ) + +-- This is used for the TH test just so it would be obvious if +-- any numbers suddenly switched between fields. +-- (e.g. uppercaseChars and lowercaseChars suddenly switch places +-- after going through validatePasswordPolicyTH) +testPolicy :: PasswordPolicy +testPolicy = + defaultPasswordPolicy + { minimumLength = 8 + , maximumLength = 64 + , uppercaseChars = 3 + , lowercaseChars = 4 + , specialChars = 5 + , digitChars = 6 + } diff --git a/test/tasty/Validate.hs b/test/tasty/Validate.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Validate.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Validate where + +import Control.Monad (replicateM) +import Data.Char (chr, isAsciiLower, isAsciiUpper, isControl, isDigit) +import Data.List (nub) +import Data.Text (Text) +import qualified Data.Text as T +import Test.QuickCheck.Instances.Text () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase) +import Test.Tasty.QuickCheck (Arbitrary (..), Gen, Property, choose, + elements, oneof, shuffle, suchThat, testProperty, + withMaxSuccess, (===)) +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif + +import Data.Password (Password, mkPassword) +import Data.Password.Validate hiding (ValidationResult(..)) +import qualified Data.Password.Validate as V + +import TestPolicy (testPolicy) +-- | Set of tests used for testing validate module +testValidate :: TestTree +testValidate = + testGroup + "Validation" + [ testDefaultCharSetPredicate + , testDefaultCharSet + , testCase "defaultCharSetPredicate accepts all of defaultCharSet" $ + assertBool "defaultCharSet includes characters defaultCharSetPredicate disallows" + $ all p defaultCharSet + , testGroup "validatePasswordPolicy" validatePasswordPolicyTests + + , testProperty + "Generator will always generate valid passwordPolicy" + $ isRight . validatePasswordPolicy + , testProperty "Valid password always true" prop_ValidPassword + , testProperty "Generator will always generate valid FailedReason" + (\(InvalidPassword reason _ _) -> either isValidPolicyReason isValidReason reason) + , testProperty "validatePassword return appropriate value" prop_InvalidPassword + ] + where + p = getCharSetPredicate defaultCharSetPredicate + +isRight :: Either a b -> Bool +isRight = either (const False) (const True) + +-- | Test that the defaultCharSetPredicate only allows non-control +-- characters from the ASCII character set. +testDefaultCharSetPredicate :: TestTree +testDefaultCharSetPredicate = testGroup "defaultCharSetPredicate" + [ testCase "Return only non-control characters" $ + assertEqual + "allows control characters" + asciiNonControlChars + $ filter p asciiCharSet + , testCase "Return true on all non-control characters" $ + assertEqual + "disallows valid characters" + asciiControlChars + $ filter (not . p) asciiCharSet + ] + where + p = getCharSetPredicate defaultCharSetPredicate + asciiCharSet, asciiControlChars, asciiNonControlChars :: [Char] + asciiCharSet = chr <$> [0 .. 127] + asciiControlChars = filter isControl asciiCharSet + asciiNonControlChars = filter (not . isControl) asciiCharSet + +testDefaultCharSet :: TestTree +testDefaultCharSet = + testCase "defaultCharSet should contain all the expected characters" $ do + hasCharacters isAsciiUpper ['A'..'Z'] "uppercase" + hasCharacters isAsciiLower ['a'..'z'] "lowercase" + hasCharacters isDigit ['0'..'9'] "digit" + hasCharacters isSpecial specials "special" + where + specials = " !\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" + -- Check that the characters filtered from defaultCharSet is as expected + hasCharacters :: (Char -> Bool) -> String -> String -> Assertion + hasCharacters pre expected s = + assertEqual msg expected $ filter pre defaultCharSet + where + msg = "Unexpected amount of " <> s <> " characters" + +defaultPassword :: Password +defaultPassword = "Abcd3fgh" + +validatePasswordPolicyTests :: [TestTree] +validatePasswordPolicyTests = + [ testCase "defaultPasswordPolicy is valid" validDefaultPasswordPolicy + , testCase "defaultCharSetPredicate is valid" validDefaultCharSetPredicate + , testCase "defaultPassword is valid" validDefaultPassword + , testProperty "upper case always valid" $ + validProp $ \i -> defaultPasswordPolicy{uppercaseChars = i} + , testProperty "lower case always valid" $ + validProp $ \i -> defaultPasswordPolicy{lowercaseChars = i} + , testProperty "digits always valid" $ + validProp $ \i -> defaultPasswordPolicy{digitChars = i} + , testProperty "special chars always valid" $ + validProp $ \i -> defaultPasswordPolicy{specialChars = i} + , testProperty "minimumLength always valid (maximumLength = maxBound)" $ + validProp $ \i -> + defaultPasswordPolicy { + minimumLength = i, + maximumLength = maxBound + } + , testProperty "minimumLength <= maximumLength always valid" $ + \i -> let maxLen = maximumLength defaultPasswordPolicy + mLength = [InvalidLength i maxLen | i > maxLen] + policy = defaultPasswordPolicy { minimumLength = i } + result = fromValidPasswordPolicy <$> validatePasswordPolicy policy + expected = case mLength of + [] -> Right policy + _ -> Left mLength + in result === expected + , testProperty "maximumLength => always valid" $ + \i -> let minLen = minimumLength defaultPasswordPolicy + mLength = [InvalidLength minLen i | i < minLen] + mZero = [MaxLengthBelowZero i | i <= 0] + mCategoryAmount = mkCategoryAmount policy + reasons = mZero ++ mLength ++ mCategoryAmount + policy = defaultPasswordPolicy { maximumLength = i } + result = fromValidPasswordPolicy <$> validatePasswordPolicy policy + expected = case reasons of + [] -> Right policy + _ -> Left reasons + in result === expected + , testGroup "TemplateHaskell" templateHaskellTest + ] + where + mkCategoryAmount p = + [ CategoryAmountsAboveMaxLength (maximumLength p) allCategoryAmounts + | allCategoryAmounts > maxLength + , maxLength > 0 + ] + where + maxLength = maximumLength p + allCategoryAmounts = sum $ max 0 <$> [lowercaseChars p, uppercaseChars p, digitChars p, specialChars p] + validProp f i = + let p = f i + result = fromValidPasswordPolicy <$> validatePasswordPolicy p + reason = mkCategoryAmount p + expected = case reason of + [] -> Right p + _ -> Left reason + in result === expected + +validDefaultPasswordPolicy :: Assertion +validDefaultPasswordPolicy = do + assertBool "defaultPasswordPolicy isn't a valid policy" + $ isRight $ validatePasswordPolicy defaultPasswordPolicy + assertBool "defaultPasswordPolicy_ isn't a valid policy" + $ Right defaultPasswordPolicy_ == validatePasswordPolicy (fromValidPasswordPolicy defaultPasswordPolicy_) + +templateHaskellTest :: [TestTree] +templateHaskellTest = + [ testCase "allButCSP check" $ assertBool + "testPolicy doesn't have unique values" + $ let ns = V.allButCSP testPolicy + in nub ns == ns + , testCase "Internal consistency" $ assertEqual + "validatePasswordPolicyTH switched values between fields" + testPolicy + $ fromValidPasswordPolicy $(validatePasswordPolicyTH testPolicy) + , testCase "defaultPassword" $ assertBool + "valid policy from TH can't parse defaultPassword" + $ isValidPassword $(validatePasswordPolicyTH defaultPasswordPolicy) defaultPassword + , testCase "TH ignores charSetPredicate (always uses default)" $ assertBool + "TH still parses defaultPassword when pred is initially bad" + $ isValidPassword + $(validatePasswordPolicyTH defaultPasswordPolicy{ charSetPredicate = CharSetPredicate $ const False }) + defaultPassword + , testProperty "prop test for charSetPredicate after TH" $ \(PredInts i) -> + let policy = $(validatePasswordPolicyTH defaultPasswordPolicy{ charSetPredicate = CharSetPredicate $ const False}) + pred = getCharSetPredicate . charSetPredicate $ fromValidPasswordPolicy policy + c = chr i + in pred c == (c `elem` defaultCharSet) + ] + +newtype PredInts = PredInts { unPredInts :: Int } deriving (Eq, Show) + +instance Arbitrary PredInts where + arbitrary = PredInts <$> choose (0, 260) + +validDefaultCharSetPredicate :: Assertion +validDefaultCharSetPredicate = + assertEqual "defaultCharSetPredicate isn't valid" [] + $ validateCharSetPredicate defaultPasswordPolicy + +validDefaultPassword :: Assertion +validDefaultPassword = + assertEqual "defaultPassword isn't valid" V.ValidPassword + $ validatePassword defaultPasswordPolicy_ defaultPassword + +-------------------------------------------------------------------------------- +-- Typeclass instances +-------------------------------------------------------------------------------- + +-- | Generate valid PasswordPolicy +instance Arbitrary PasswordPolicy where + arbitrary = do + minimumLength <- genCharLength + uppercaseChars <- genCharLength + lowercaseChars <- genCharLength + specialChars <- genCharLength + digitChars <- genCharLength + let sumLength = sum [uppercaseChars, lowercaseChars, specialChars, digitChars] + let minMaxLength = max minimumLength sumLength + maximumLength <- choose (minMaxLength, minMaxLength + 10) + let charSetPredicate = defaultCharSetPredicate + return PasswordPolicy{..} + where + genCharLength :: Gen Int + genCharLength = choose (1, 10) + +instance Arbitrary CharacterCategory where + arbitrary = elements [Uppercase, Lowercase, Special, Digit] + +-- This is needed for testing (QuickCheck requires given datatype to have Show instance) +instance Show CharSetPredicate where + show _ = "Predicate" + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +-- | Test that 'validatePassword' will always return empty list if the password +-- is valid +prop_ValidPassword :: ValidPassword -> Property +prop_ValidPassword (ValidPassword passwordPolicy password) = + withMaxSuccess 1000 $ + case validatePasswordPolicy passwordPolicy of + Left _ -> error "PasswordPolicy is invalid" + Right validPolicy -> validatePassword validPolicy (mkPassword password) === V.ValidPassword + +-- | Data type used to generate valid password and 'PasswordPolicy' associated +-- with it +data ValidPassword = ValidPassword + { validPasswordPolicy :: !PasswordPolicy + , validPasswordText :: !Text + } deriving (Show) + +instance Arbitrary ValidPassword where + arbitrary = do + policy@PasswordPolicy{..} <- arbitrary + passLength <- choose (minimumLength, maximumLength) + passwordText <- genPassword passLength policy + return $ ValidPassword policy passwordText + where + genPassword :: Int -> PasswordPolicy -> Gen Text + genPassword passLength PasswordPolicy{..} = do + upperCase <- genStr uppercaseChars isAsciiUpper + lowerCase <- genStr lowercaseChars isAsciiLower + specialChar <- genStr specialChars isSpecial + digit <- genStr digitChars isDigit + let requiredChars = upperCase <> lowerCase <> specialChar <> digit + let toFill = passLength - length requiredChars + fillChars <- replicateM toFill $ + arbitrary `suchThat` getCharSetPredicate charSetPredicate + T.pack <$> shuffle (fillChars <> requiredChars) + genStr :: Int -> (Char -> Bool) -> Gen String + genStr num predicate = replicateM num (arbitrary `suchThat` predicate) + +prop_InvalidPassword :: InvalidPassword -> Property +prop_InvalidPassword (InvalidPassword failedReason passwordPolicy password) = + withMaxSuccess 1000 $ (===) expected $ + case validatePasswordPolicy passwordPolicy of + Left policyReasons -> Left policyReasons + Right validPolicy -> Right $ validatePassword validPolicy (mkPassword password) + where + expected = either (Left . pure) (Right . V.InvalidPassword . pure) failedReason + +-- | Data type used to generate password which does not follow one of the policies +-- as well as 'InvalidReason', 'CharSetPredicate', and 'PasswordPolicy' associated with it +data InvalidPassword = InvalidPassword + { invalidPassFailedReason :: !(Either InvalidPolicyReason InvalidReason) + , invalidPassPolicy :: !PasswordPolicy + , invalidPasswordText :: !Text + } deriving (Show) + +instance Arbitrary InvalidPassword where + arbitrary = do + reason <- genFailedReason emptyPolicy + let charSetP = updateCharSetPredicate defaultCharSetPredicate reason + updatedPolicy = (updatePolicy emptyPolicy reason){ charSetPredicate = charSetP } + passText <- genInvalidPassword updatedPolicy reason + return $ InvalidPassword reason updatedPolicy (T.pack passText) + where + genFailedReason :: PasswordPolicy -> Gen (Either InvalidPolicyReason InvalidReason) + genFailedReason policy@PasswordPolicy{..} = + oneof + [ Right <$> genTooShort maximumLength, + Right <$> genTooLong minimumLength, + Right <$> genNotEnoughRequiredChars, + Right <$> genInvalidChar defaultCharSetPredicate, + Left <$> oneof + [ MaxLengthBelowZero <$> (arbitrary `suchThat` (<= 0)) + , genInvalidLength policy + , genInvalidCategoryAmountTotal policy + , InvalidCharSetPredicate <$> arbitrary <*> choose (minimumLength, maximumLength) + ] + ] + genTooShort :: Int -> Gen InvalidReason + genTooShort maxLength = do + requiredLength <- choose (1, maxLength - 1) + actualLength <- choose (0, requiredLength - 1) + return $ PasswordTooShort requiredLength actualLength + genTooLong :: Int -> Gen InvalidReason + genTooLong minLength = do + requiredLength <- choose (minLength + 1, 30) + actualLength <- choose (requiredLength + 1, 50) + return $ PasswordTooLong requiredLength actualLength + genNotEnoughRequiredChars :: Gen InvalidReason + genNotEnoughRequiredChars = do + required <- choose (1, 3) + actual <- choose (0, required - 1) + category <- arbitrary + return $ NotEnoughReqChars category required actual + genInvalidChar :: CharSetPredicate -> Gen InvalidReason + genInvalidChar (CharSetPredicate predicate) = do + num <- choose (1, 3) + let arbitraryInvalidChar = arbitrary `suchThat` (not . predicate) + chrs <- replicateM num arbitraryInvalidChar + return $ InvalidCharacters (T.pack chrs) + genInvalidLength :: PasswordPolicy -> Gen InvalidPolicyReason + genInvalidLength PasswordPolicy{..} = do + let sumReq = sum [uppercaseChars, lowercaseChars, specialChars, digitChars] + minLength <- choose (sumReq, maximumLength - 1) `suchThat` (> 0) + return $ InvalidLength maximumLength minLength + genInvalidCategoryAmountTotal :: PasswordPolicy -> Gen InvalidPolicyReason + genInvalidCategoryAmountTotal p = do + maxLength <- arbitrary `suchThat` (> minimumLength p) + let totalAmount = maxLength + 1 + return $ CategoryAmountsAboveMaxLength maxLength totalAmount + -- Update 'PasswordPolicy' based upon 'InvalidReason' + updatePolicy :: PasswordPolicy -> Either InvalidPolicyReason InvalidReason -> PasswordPolicy + updatePolicy policy = \case + Right (PasswordTooShort req _actual) -> policy {minimumLength = req} + Right (PasswordTooLong req _actual) -> policy {maximumLength = req} + Right (InvalidCharacters _invalidChars) -> policy + Right (NotEnoughReqChars category req _actual) -> + case category of + Uppercase -> policy {uppercaseChars = req} + Lowercase -> policy {lowercaseChars = req} + Special -> policy {specialChars = req} + Digit -> policy {digitChars = req} + Left (MaxLengthBelowZero num) -> + policy { + minimumLength = num - 1, + maximumLength = num + } + Left (InvalidLength minLength maxLength) -> + policy { + minimumLength = minLength, + maximumLength = maxLength + } + Left (CategoryAmountsAboveMaxLength maxLength totalAmount) -> + policy { + maximumLength = maxLength, + lowercaseChars = totalAmount + } + Left (InvalidCharSetPredicate category num) -> + case category of + Uppercase -> policy {uppercaseChars = num} + Lowercase -> policy {lowercaseChars = num} + Special -> policy {specialChars = num} + Digit -> policy {digitChars = num} + updateCharSetPredicate :: CharSetPredicate -> Either InvalidPolicyReason InvalidReason -> CharSetPredicate + updateCharSetPredicate predicate = \case + Right (InvalidCharacters invalidChars) -> + CharSetPredicate $ \c -> getCharSetPredicate predicate c && c `notElem` T.unpack invalidChars + Left (InvalidCharSetPredicate category _num) -> + let filterPre = categoryToPredicate category + in CharSetPredicate $ \c -> getCharSetPredicate predicate c && (not . filterPre) c + _others -> predicate + genInvalidPassword :: PasswordPolicy -> Either InvalidPolicyReason InvalidReason -> Gen String + genInvalidPassword policy@PasswordPolicy{..} = \case + Right (PasswordTooShort _req actual) -> genPassword actual charSetPredicate + Right (PasswordTooLong _req actual) -> genPassword actual charSetPredicate + Right (NotEnoughReqChars category _req actual) -> do + passwordLength <- genPasswordLength policy + let pre = categoryToPredicate category + let usableCharsets = CharSetPredicate $ \c -> not (pre c) && getCharSetPredicate charSetPredicate c + requiredChars <- replicateM actual (arbitrary `suchThat` pre) + passwordText <- genPassword (passwordLength - actual) usableCharsets + shuffle (passwordText <> requiredChars) + Right (InvalidCharacters chrs) -> do + passwordLength <- genPasswordLength policy + passwordText <- genPassword (passwordLength - T.length chrs) charSetPredicate + -- Here, we make sure that the order of invalid characters are apporiate + -- or else the test will fail. For instance this will make the test fail + -- since the order of the characters are different + -- e.g. [InvalidChar "一二三"] /= [InvalidChar "三二一"] + let s = T.unpack chrs + shuffle (passwordText <> s) `suchThat` checkOrder charSetPredicate s + Left (MaxLengthBelowZero _invalid) -> genPassword minimumLength charSetPredicate + _others -> do + passwordLength <- genPasswordLength policy + genPassword passwordLength charSetPredicate + genPassword :: Int -> CharSetPredicate -> Gen String + genPassword num (CharSetPredicate predicate) = replicateM num (arbitrary `suchThat` predicate) + genPasswordLength :: PasswordPolicy -> Gen Int + genPasswordLength PasswordPolicy{..} = choose (minimumLength, maximumLength) + checkOrder :: CharSetPredicate -> String -> String -> Bool + checkOrder (CharSetPredicate predicate) invalidChars password = + let filteredChars = filter (not . predicate) password + in invalidChars == filteredChars + +-- | Check if given 'InvalidReason' is valid +isValidReason :: InvalidReason -> Bool +isValidReason = \case + InvalidCharacters _ -> True + PasswordTooLong required actual -> required < actual + PasswordTooShort required actual -> required > actual + NotEnoughReqChars _ required actual -> required > actual + +isValidPolicyReason :: InvalidPolicyReason -> Bool +isValidPolicyReason = \case + InvalidLength minLength maxLength -> minLength > maxLength + MaxLengthBelowZero num -> num <= 0 + CategoryAmountsAboveMaxLength maxLength num -> num > maxLength + InvalidCharSetPredicate _category num -> num > 0 + +-- | 'PasswordPolicy' used for testing +-- +-- Required characters are turned off so that it's much more easier to test. +emptyPolicy :: PasswordPolicy +emptyPolicy = PasswordPolicy 8 32 0 0 0 0 defaultCharSetPredicate