password 2.0.1.1 → 2.1.0.0

raw patch · 7 files changed

+1050/−7 lines, 7 filesdep +tasty-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−4
• password.cabal +7/−2
• src/Data/Password/Internal.hs +0/−1
• src/Data/Password/Validate.hs +569/−0
• test/tasty/Spec.hs +2/−0
• test/tasty/TestPolicy.hs +21/−0
• test/tasty/Validate.hs +437/−0

@@ -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 

@@ -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:

@@ -141,4 +141,3 @@ showT :: forall a. Show a => a -> Text showT = T.pack . show {-# INLINE showT #-}-

@@ -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 = <FUNCTION>}"+    ]++-- | 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 = <FUNCTION>}+--+-- @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]

@@ -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     ]

@@ -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+        }

@@ -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