{-# 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. The most obvious
requirement being a minimum length, but another common requirement is for
the password to at least include a certain amount of characters of a certain
category, like uppercase and lowercase alphabetic characters, numbers and/or
other special characters. /Though, nowadays, this last type of requirement is/
/discouraged by security experts/.

This module provides an API which enables you to set up your own
'PasswordPolicy' to validate the format of 'Password's.

== /Recommendations by the NIST/

For policy recommendations and more, look to the following publication by
the National Institute of Standards and Technology (especially the addendum):
<https://nvlpubs.nist.gov/nistpubs/SpecialPublications/NIST.SP.800-63b.pdf>

A short summary:

* Enforcing inclusion of specific character types (like special characters,
numbers, lowercase and uppercase letters) actually makes passwords __less secure__.
* The length of a password is __the most important__ factor, so let
users make their passwords as lengthy as they want, within reason.
(keep in mind some algorithms have length limitations, like /bcrypt/'s
72 character limit)
* Do allow spaces so users can use sentences for passwords.
* Showing the "strength" of user's passwords is advised. A good algorithm
to use is /zxcvbn/.
* The best way to mitigate online attacks is to limit the rate of login attempts.

== Password Policies

The most important part is to have a valid and robust 'PasswordPolicy'.

A 'defaultPasswordPolicy_' is provided to quickly set up a NIST recommended
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 doesn't enforce any specific
character category usage, 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')

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.Types (Password, unsafeShowPassword)

-- $setup
-- >>> :set -XOverloadedStrings
--
-- Import needed libraries.
--
-- >>> import Data.Password.Types

-- | 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
    { PasswordPolicy -> Int
minimumLength  :: !Int
    -- ^ Required password minimum length
    , PasswordPolicy -> Int
maximumLength  :: !Int
    -- ^ Required password maximum length
    , PasswordPolicy -> Int
uppercaseChars :: !Int
    -- ^ Required number of upper-case characters
    , PasswordPolicy -> Int
lowercaseChars :: !Int
    -- ^ Required number of lower-case characters
    , PasswordPolicy -> Int
specialChars   :: !Int
    -- ^ Required number of special characters
    , PasswordPolicy -> Int
digitChars     :: !Int
    -- ^ Required number of ASCII-digit characters
    , PasswordPolicy -> CharSetPredicate
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 -> [Int]
allButCSP PasswordPolicy{Int
CharSetPredicate
charSetPredicate :: CharSetPredicate
digitChars :: Int
specialChars :: Int
lowercaseChars :: Int
uppercaseChars :: Int
maximumLength :: Int
minimumLength :: Int
charSetPredicate :: PasswordPolicy -> CharSetPredicate
digitChars :: PasswordPolicy -> Int
specialChars :: PasswordPolicy -> Int
lowercaseChars :: PasswordPolicy -> Int
uppercaseChars :: PasswordPolicy -> Int
maximumLength :: PasswordPolicy -> Int
minimumLength :: PasswordPolicy -> Int
..} =
  [ Int
minimumLength
  , Int
maximumLength
  , Int
uppercaseChars
  , Int
lowercaseChars
  , Int
specialChars
  , Int
digitChars
  ]

-- | N.B. This will not check equality on the 'charSetPredicate'
instance Eq PasswordPolicy where
  == :: PasswordPolicy -> PasswordPolicy -> Bool
(==) = [Int] -> [Int] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
go ([Int] -> [Int] -> Bool)
-> (PasswordPolicy -> [Int])
-> PasswordPolicy
-> PasswordPolicy
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PasswordPolicy -> [Int]
allButCSP
    where
      go :: [a] -> [a] -> Bool
go [a]
a [a]
b = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> [a] -> [a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) [a]
a [a]
b

-- | N.B. This will not check order on the 'charSetPredicate'
instance Ord PasswordPolicy where
  compare :: PasswordPolicy -> PasswordPolicy -> Ordering
compare = [Int] -> [Int] -> Ordering
forall a. Ord a => [a] -> [a] -> Ordering
go ([Int] -> [Int] -> Ordering)
-> (PasswordPolicy -> [Int])
-> PasswordPolicy
-> PasswordPolicy
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PasswordPolicy -> [Int]
allButCSP
    where
      go :: [a] -> [a] -> Ordering
go [a]
a [a]
b = [Ordering] -> Ordering
check ([Ordering] -> Ordering) -> [Ordering] -> Ordering
forall a b. (a -> b) -> a -> b
$ (a -> a -> Ordering) -> [a] -> [a] -> [Ordering]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [a]
a [a]
b
      check :: [Ordering] -> Ordering
check [] = Ordering
EQ
      check (Ordering
EQ : [Ordering]
xs) = [Ordering] -> Ordering
check [Ordering]
xs
      check (Ordering
x : [Ordering]
_) = Ordering
x

instance Show PasswordPolicy where
  show :: PasswordPolicy -> String
show PasswordPolicy{Int
CharSetPredicate
charSetPredicate :: CharSetPredicate
digitChars :: Int
specialChars :: Int
lowercaseChars :: Int
uppercaseChars :: Int
maximumLength :: Int
minimumLength :: Int
charSetPredicate :: PasswordPolicy -> CharSetPredicate
digitChars :: PasswordPolicy -> Int
specialChars :: PasswordPolicy -> Int
lowercaseChars :: PasswordPolicy -> Int
uppercaseChars :: PasswordPolicy -> Int
maximumLength :: PasswordPolicy -> Int
minimumLength :: PasswordPolicy -> Int
..} = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"PasswordPolicy {"
    , String
"minimumLength = ", Int -> String
forall a. Show a => a -> String
show Int
minimumLength
    , String
", maximumLength = ", Int -> String
forall a. Show a => a -> String
show Int
maximumLength
    , String
", uppercaseChars = ", Int -> String
forall a. Show a => a -> String
show Int
uppercaseChars
    , String
", lowercaseChars = ", Int -> String
forall a. Show a => a -> String
show Int
lowercaseChars
    , String
", specialChars = ", Int -> String
forall a. Show a => a -> String
show Int
specialChars
    , String
", digitChars = ", Int -> String
forall a. Show a => a -> String
show Int
digitChars
    , String
", charSetPredicate = <FUNCTION>}"
    ]

-- | A 'PasswordPolicy' that has been checked to be valid
--
-- @since 2.1.0.0
newtype ValidPasswordPolicy = VPP
  { ValidPasswordPolicy -> PasswordPolicy
fromValidPasswordPolicy :: PasswordPolicy
    -- ^
    -- In case you'd want to retrieve the 'PasswordPolicy'
    -- from the 'ValidPasswordPolicy'
    --
    -- @since 2.1.0.0
  } deriving (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
(ValidPasswordPolicy -> ValidPasswordPolicy -> Bool)
-> (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool)
-> Eq ValidPasswordPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
$c/= :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
== :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
$c== :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
Eq, Eq ValidPasswordPolicy
Eq ValidPasswordPolicy
-> (ValidPasswordPolicy -> ValidPasswordPolicy -> Ordering)
-> (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool)
-> (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool)
-> (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool)
-> (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool)
-> (ValidPasswordPolicy
    -> ValidPasswordPolicy -> ValidPasswordPolicy)
-> (ValidPasswordPolicy
    -> ValidPasswordPolicy -> ValidPasswordPolicy)
-> Ord ValidPasswordPolicy
ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
ValidPasswordPolicy -> ValidPasswordPolicy -> Ordering
ValidPasswordPolicy -> ValidPasswordPolicy -> ValidPasswordPolicy
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ValidPasswordPolicy -> ValidPasswordPolicy -> ValidPasswordPolicy
$cmin :: ValidPasswordPolicy -> ValidPasswordPolicy -> ValidPasswordPolicy
max :: ValidPasswordPolicy -> ValidPasswordPolicy -> ValidPasswordPolicy
$cmax :: ValidPasswordPolicy -> ValidPasswordPolicy -> ValidPasswordPolicy
>= :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
$c>= :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
> :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
$c> :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
<= :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
$c<= :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
< :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
$c< :: ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
compare :: ValidPasswordPolicy -> ValidPasswordPolicy -> Ordering
$ccompare :: ValidPasswordPolicy -> ValidPasswordPolicy -> Ordering
$cp1Ord :: Eq ValidPasswordPolicy
Ord, Int -> ValidPasswordPolicy -> ShowS
[ValidPasswordPolicy] -> ShowS
ValidPasswordPolicy -> String
(Int -> ValidPasswordPolicy -> ShowS)
-> (ValidPasswordPolicy -> String)
-> ([ValidPasswordPolicy] -> ShowS)
-> Show ValidPasswordPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidPasswordPolicy] -> ShowS
$cshowList :: [ValidPasswordPolicy] -> ShowS
show :: ValidPasswordPolicy -> String
$cshow :: ValidPasswordPolicy -> String
showsPrec :: Int -> ValidPasswordPolicy -> ShowS
$cshowsPrec :: Int -> ValidPasswordPolicy -> ShowS
Show)

-- | Default value for the 'PasswordPolicy'.
--
-- Enforces that a password must be between 8-64 characters long,
-- though can easily be adjusted by using record update syntax:
--
-- @
-- myPolicy = defaultPasswordPolicy{ minimumLength = 12 }
-- @
--
-- /Do note that this being a default policy doesn't make it a good/
-- /enough policy in every situation. The most important field, 'minimumLength',/
-- /has 8 characters as the default, because it is the bare minimum for some/
-- /sense of security. The longer the password, the more difficult it will be/
-- /to guess or brute-force, so a minimum of 12 or 16 would be advised in/
-- /a production setting./
--
-- 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 = 0, lowercaseChars = 0, specialChars = 0, digitChars = 0, charSetPredicate = <FUNCTION>}
--
-- @since 2.1.0.0
defaultPasswordPolicy :: PasswordPolicy
defaultPasswordPolicy :: PasswordPolicy
defaultPasswordPolicy = PasswordPolicy :: Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> CharSetPredicate
-> PasswordPolicy
PasswordPolicy
  { minimumLength :: Int
minimumLength = Int
8,
    maximumLength :: Int
maximumLength = Int
64,
    uppercaseChars :: Int
uppercaseChars = Int
0,
    lowercaseChars :: Int
lowercaseChars = Int
0,
    specialChars :: Int
specialChars = Int
0,
    digitChars :: Int
digitChars = Int
0,
    charSetPredicate :: CharSetPredicate
charSetPredicate = CharSetPredicate
defaultCharSetPredicate
  }

-- | Unchangeable 'defaultPasswordPolicy', but guaranteed to be valid.
--
-- @since 2.1.0.0
defaultPasswordPolicy_ :: ValidPasswordPolicy
defaultPasswordPolicy_ :: ValidPasswordPolicy
defaultPasswordPolicy_ = PasswordPolicy -> ValidPasswordPolicy
VPP PasswordPolicy
defaultPasswordPolicy

-- | Predicate which defines the characters that can be used for a password.
--
-- @since 2.1.0.0
newtype CharSetPredicate = CharSetPredicate
  { CharSetPredicate -> Char -> Bool
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
defaultCharSetPredicate =  (Char -> Bool) -> CharSetPredicate
CharSetPredicate ((Char -> Bool) -> CharSetPredicate)
-> (Char -> Bool) -> CharSetPredicate
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
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 :: Char -> Bool
isSpecial = \Char
c ->
    Char -> Bool
isDefault Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c)
  where
    CharSetPredicate Char -> Bool
isDefault = CharSetPredicate
defaultCharSetPredicate

-- | Character categories
--
-- @since 2.1.0.0
data CharacterCategory
  = Uppercase
  -- ^ Uppercase letters
  | Lowercase
  -- ^ Lowercase letters
  | Special
  -- ^ Special characters
  | Digit
  -- ^ ASCII digits
  deriving (CharacterCategory -> CharacterCategory -> Bool
(CharacterCategory -> CharacterCategory -> Bool)
-> (CharacterCategory -> CharacterCategory -> Bool)
-> Eq CharacterCategory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CharacterCategory -> CharacterCategory -> Bool
$c/= :: CharacterCategory -> CharacterCategory -> Bool
== :: CharacterCategory -> CharacterCategory -> Bool
$c== :: CharacterCategory -> CharacterCategory -> Bool
Eq, Eq CharacterCategory
Eq CharacterCategory
-> (CharacterCategory -> CharacterCategory -> Ordering)
-> (CharacterCategory -> CharacterCategory -> Bool)
-> (CharacterCategory -> CharacterCategory -> Bool)
-> (CharacterCategory -> CharacterCategory -> Bool)
-> (CharacterCategory -> CharacterCategory -> Bool)
-> (CharacterCategory -> CharacterCategory -> CharacterCategory)
-> (CharacterCategory -> CharacterCategory -> CharacterCategory)
-> Ord CharacterCategory
CharacterCategory -> CharacterCategory -> Bool
CharacterCategory -> CharacterCategory -> Ordering
CharacterCategory -> CharacterCategory -> CharacterCategory
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CharacterCategory -> CharacterCategory -> CharacterCategory
$cmin :: CharacterCategory -> CharacterCategory -> CharacterCategory
max :: CharacterCategory -> CharacterCategory -> CharacterCategory
$cmax :: CharacterCategory -> CharacterCategory -> CharacterCategory
>= :: CharacterCategory -> CharacterCategory -> Bool
$c>= :: CharacterCategory -> CharacterCategory -> Bool
> :: CharacterCategory -> CharacterCategory -> Bool
$c> :: CharacterCategory -> CharacterCategory -> Bool
<= :: CharacterCategory -> CharacterCategory -> Bool
$c<= :: CharacterCategory -> CharacterCategory -> Bool
< :: CharacterCategory -> CharacterCategory -> Bool
$c< :: CharacterCategory -> CharacterCategory -> Bool
compare :: CharacterCategory -> CharacterCategory -> Ordering
$ccompare :: CharacterCategory -> CharacterCategory -> Ordering
$cp1Ord :: Eq CharacterCategory
Ord, Int -> CharacterCategory -> ShowS
[CharacterCategory] -> ShowS
CharacterCategory -> String
(Int -> CharacterCategory -> ShowS)
-> (CharacterCategory -> String)
-> ([CharacterCategory] -> ShowS)
-> Show CharacterCategory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CharacterCategory] -> ShowS
$cshowList :: [CharacterCategory] -> ShowS
show :: CharacterCategory -> String
$cshow :: CharacterCategory -> String
showsPrec :: Int -> CharacterCategory -> ShowS
$cshowsPrec :: Int -> CharacterCategory -> ShowS
Show)

-- @since 2.1.0.0
-- | Convert a 'CharacterCategory' into its associated predicate function
categoryToPredicate :: CharacterCategory -> (Char -> Bool)
categoryToPredicate :: CharacterCategory -> Char -> Bool
categoryToPredicate = \case
  CharacterCategory
Uppercase -> Char -> Bool
isAsciiUpper
  CharacterCategory
Lowercase -> Char -> Bool
isAsciiLower
  CharacterCategory
Special -> Char -> Bool
isSpecial
  CharacterCategory
Digit -> Char -> Bool
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 (InvalidReason -> InvalidReason -> Bool
(InvalidReason -> InvalidReason -> Bool)
-> (InvalidReason -> InvalidReason -> Bool) -> Eq InvalidReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidReason -> InvalidReason -> Bool
$c/= :: InvalidReason -> InvalidReason -> Bool
== :: InvalidReason -> InvalidReason -> Bool
$c== :: InvalidReason -> InvalidReason -> Bool
Eq, Eq InvalidReason
Eq InvalidReason
-> (InvalidReason -> InvalidReason -> Ordering)
-> (InvalidReason -> InvalidReason -> Bool)
-> (InvalidReason -> InvalidReason -> Bool)
-> (InvalidReason -> InvalidReason -> Bool)
-> (InvalidReason -> InvalidReason -> Bool)
-> (InvalidReason -> InvalidReason -> InvalidReason)
-> (InvalidReason -> InvalidReason -> InvalidReason)
-> Ord InvalidReason
InvalidReason -> InvalidReason -> Bool
InvalidReason -> InvalidReason -> Ordering
InvalidReason -> InvalidReason -> InvalidReason
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InvalidReason -> InvalidReason -> InvalidReason
$cmin :: InvalidReason -> InvalidReason -> InvalidReason
max :: InvalidReason -> InvalidReason -> InvalidReason
$cmax :: InvalidReason -> InvalidReason -> InvalidReason
>= :: InvalidReason -> InvalidReason -> Bool
$c>= :: InvalidReason -> InvalidReason -> Bool
> :: InvalidReason -> InvalidReason -> Bool
$c> :: InvalidReason -> InvalidReason -> Bool
<= :: InvalidReason -> InvalidReason -> Bool
$c<= :: InvalidReason -> InvalidReason -> Bool
< :: InvalidReason -> InvalidReason -> Bool
$c< :: InvalidReason -> InvalidReason -> Bool
compare :: InvalidReason -> InvalidReason -> Ordering
$ccompare :: InvalidReason -> InvalidReason -> Ordering
$cp1Ord :: Eq InvalidReason
Ord, Int -> InvalidReason -> ShowS
[InvalidReason] -> ShowS
InvalidReason -> String
(Int -> InvalidReason -> ShowS)
-> (InvalidReason -> String)
-> ([InvalidReason] -> ShowS)
-> Show InvalidReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidReason] -> ShowS
$cshowList :: [InvalidReason] -> ShowS
show :: InvalidReason -> String
$cshow :: InvalidReason -> String
showsPrec :: Int -> InvalidReason -> ShowS
$cshowsPrec :: Int -> InvalidReason -> ShowS
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 (InvalidPolicyReason -> InvalidPolicyReason -> Bool
(InvalidPolicyReason -> InvalidPolicyReason -> Bool)
-> (InvalidPolicyReason -> InvalidPolicyReason -> Bool)
-> Eq InvalidPolicyReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
$c/= :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
== :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
$c== :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
Eq, Eq InvalidPolicyReason
Eq InvalidPolicyReason
-> (InvalidPolicyReason -> InvalidPolicyReason -> Ordering)
-> (InvalidPolicyReason -> InvalidPolicyReason -> Bool)
-> (InvalidPolicyReason -> InvalidPolicyReason -> Bool)
-> (InvalidPolicyReason -> InvalidPolicyReason -> Bool)
-> (InvalidPolicyReason -> InvalidPolicyReason -> Bool)
-> (InvalidPolicyReason
    -> InvalidPolicyReason -> InvalidPolicyReason)
-> (InvalidPolicyReason
    -> InvalidPolicyReason -> InvalidPolicyReason)
-> Ord InvalidPolicyReason
InvalidPolicyReason -> InvalidPolicyReason -> Bool
InvalidPolicyReason -> InvalidPolicyReason -> Ordering
InvalidPolicyReason -> InvalidPolicyReason -> InvalidPolicyReason
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InvalidPolicyReason -> InvalidPolicyReason -> InvalidPolicyReason
$cmin :: InvalidPolicyReason -> InvalidPolicyReason -> InvalidPolicyReason
max :: InvalidPolicyReason -> InvalidPolicyReason -> InvalidPolicyReason
$cmax :: InvalidPolicyReason -> InvalidPolicyReason -> InvalidPolicyReason
>= :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
$c>= :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
> :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
$c> :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
<= :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
$c<= :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
< :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
$c< :: InvalidPolicyReason -> InvalidPolicyReason -> Bool
compare :: InvalidPolicyReason -> InvalidPolicyReason -> Ordering
$ccompare :: InvalidPolicyReason -> InvalidPolicyReason -> Ordering
$cp1Ord :: Eq InvalidPolicyReason
Ord, Int -> InvalidPolicyReason -> ShowS
[InvalidPolicyReason] -> ShowS
InvalidPolicyReason -> String
(Int -> InvalidPolicyReason -> ShowS)
-> (InvalidPolicyReason -> String)
-> ([InvalidPolicyReason] -> ShowS)
-> Show InvalidPolicyReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidPolicyReason] -> ShowS
$cshowList :: [InvalidPolicyReason] -> ShowS
show :: InvalidPolicyReason -> String
$cshow :: InvalidPolicyReason -> String
showsPrec :: Int -> InvalidPolicyReason -> ShowS
$cshowsPrec :: Int -> InvalidPolicyReason -> ShowS
Show)

-- | Result of validating a 'Password'.
--
-- @since 2.1.0.0
data ValidationResult = ValidPassword | InvalidPassword [InvalidReason]
  deriving (ValidationResult -> ValidationResult -> Bool
(ValidationResult -> ValidationResult -> Bool)
-> (ValidationResult -> ValidationResult -> Bool)
-> Eq ValidationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationResult -> ValidationResult -> Bool
$c/= :: ValidationResult -> ValidationResult -> Bool
== :: ValidationResult -> ValidationResult -> Bool
$c== :: ValidationResult -> ValidationResult -> Bool
Eq, Int -> ValidationResult -> ShowS
[ValidationResult] -> ShowS
ValidationResult -> String
(Int -> ValidationResult -> ShowS)
-> (ValidationResult -> String)
-> ([ValidationResult] -> ShowS)
-> Show ValidationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationResult] -> ShowS
$cshowList :: [ValidationResult] -> ShowS
show :: ValidationResult -> String
$cshow :: ValidationResult -> String
showsPrec :: Int -> ValidationResult -> ShowS
$cshowsPrec :: Int -> ValidationResult -> ShowS
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 :: ValidPasswordPolicy -> Password -> Bool
isValidPassword ValidPasswordPolicy
policy Password
pass = ValidPasswordPolicy -> Password -> ValidationResult
validatePassword ValidPasswordPolicy
policy Password
pass ValidationResult -> ValidationResult -> Bool
forall a. Eq a => a -> a -> Bool
== ValidationResult
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 :: ValidPasswordPolicy -> Password -> ValidationResult
validatePassword (VPP PasswordPolicy{Int
CharSetPredicate
charSetPredicate :: CharSetPredicate
digitChars :: Int
specialChars :: Int
lowercaseChars :: Int
uppercaseChars :: Int
maximumLength :: Int
minimumLength :: Int
charSetPredicate :: PasswordPolicy -> CharSetPredicate
digitChars :: PasswordPolicy -> Int
specialChars :: PasswordPolicy -> Int
lowercaseChars :: PasswordPolicy -> Int
uppercaseChars :: PasswordPolicy -> Int
maximumLength :: PasswordPolicy -> Int
minimumLength :: PasswordPolicy -> Int
..}) Password
pass =
  case [InvalidReason]
validationFailures of
    [] -> ValidationResult
ValidPassword
    InvalidReason
_:[InvalidReason]
_ -> [InvalidReason] -> ValidationResult
InvalidPassword [InvalidReason]
validationFailures

  where
    password :: Text
password = Password -> Text
unsafeShowPassword Password
pass
    validationFailures :: [InvalidReason]
validationFailures = [[InvalidReason]] -> [InvalidReason]
forall a. Monoid a => [a] -> a
mconcat
        [ [InvalidReason]
isTooShort
        , [InvalidReason]
isTooLong
        , [InvalidReason]
isUsingValidCharacters
        , Int -> CharacterCategory -> [InvalidReason]
hasRequiredChar Int
uppercaseChars CharacterCategory
Uppercase
        , Int -> CharacterCategory -> [InvalidReason]
hasRequiredChar Int
lowercaseChars CharacterCategory
Lowercase
        , Int -> CharacterCategory -> [InvalidReason]
hasRequiredChar Int
specialChars CharacterCategory
Special
        , Int -> CharacterCategory -> [InvalidReason]
hasRequiredChar Int
digitChars CharacterCategory
Digit
        ]
    len :: Int
len = Text -> Int
T.length Text
password
    isTooLong :: [InvalidReason]
isTooLong = [Int -> Int -> InvalidReason
PasswordTooLong Int
maximumLength Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maximumLength]
    isTooShort :: [InvalidReason]
isTooShort = [Int -> Int -> InvalidReason
PasswordTooShort Int
minimumLength Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minimumLength]

    CharSetPredicate Char -> Bool
predicate = CharSetPredicate
charSetPredicate
    isUsingValidCharacters :: [InvalidReason]
    isUsingValidCharacters :: [InvalidReason]
isUsingValidCharacters =
        let filteredText :: Text
filteredText = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
predicate) Text
password
        in [Text -> InvalidReason
InvalidCharacters Text
filteredText | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
filteredText]
    hasRequiredChar :: Int -> CharacterCategory -> [InvalidReason]
    hasRequiredChar :: Int -> CharacterCategory -> [InvalidReason]
hasRequiredChar Int
requiredCharNum CharacterCategory
characterCategory
      | Int
requiredCharNum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = []
      | Bool
otherwise =
          let p :: Char -> Bool
p = CharacterCategory -> Char -> Bool
categoryToPredicate CharacterCategory
characterCategory
              actualRequiredCharNum :: Int
actualRequiredCharNum = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
p Text
password
          in [ CharacterCategory -> Int -> Int -> InvalidReason
NotEnoughReqChars CharacterCategory
characterCategory Int
requiredCharNum Int
actualRequiredCharNum
             | Int
actualRequiredCharNum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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 -> [InvalidPolicyReason]
validateCharSetPredicate PasswordPolicy{Int
CharSetPredicate
charSetPredicate :: CharSetPredicate
digitChars :: Int
specialChars :: Int
lowercaseChars :: Int
uppercaseChars :: Int
maximumLength :: Int
minimumLength :: Int
charSetPredicate :: PasswordPolicy -> CharSetPredicate
digitChars :: PasswordPolicy -> Int
specialChars :: PasswordPolicy -> Int
lowercaseChars :: PasswordPolicy -> Int
uppercaseChars :: PasswordPolicy -> Int
maximumLength :: PasswordPolicy -> Int
minimumLength :: PasswordPolicy -> Int
..} =
  let charSets :: [(Int, CharacterCategory, String)]
charSets = [(Int, CharacterCategory)] -> [(Int, CharacterCategory, String)]
accumulateCharSet
        [ (Int
uppercaseChars, CharacterCategory
Uppercase)
        , (Int
lowercaseChars, CharacterCategory
Lowercase)
        , (Int
specialChars, CharacterCategory
Special)
        , (Int
digitChars, CharacterCategory
Digit)
        ]
  in ((Int, CharacterCategory, String) -> [InvalidPolicyReason])
-> [(Int, CharacterCategory, String)] -> [InvalidPolicyReason]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, CharacterCategory, String) -> [InvalidPolicyReason]
checkPredicate [(Int, CharacterCategory, String)]
charSets
  where
    CharSetPredicate Char -> Bool
predicate = CharSetPredicate
charSetPredicate
    checkPredicate :: (Int, CharacterCategory, String) -> [InvalidPolicyReason]
    checkPredicate :: (Int, CharacterCategory, String) -> [InvalidPolicyReason]
checkPredicate (Int
num, CharacterCategory
category, String
sets) =
      [CharacterCategory -> Int -> InvalidPolicyReason
InvalidCharSetPredicate CharacterCategory
category Int
num | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
predicate String
sets]
    accumulateCharSet :: [(Int, CharacterCategory)] -> [(Int, CharacterCategory, String)]
    accumulateCharSet :: [(Int, CharacterCategory)] -> [(Int, CharacterCategory, String)]
accumulateCharSet [(Int, CharacterCategory)]
xs =
      [ (Int
num, CharacterCategory
c, CharacterCategory -> String
categoryToString CharacterCategory
c)
      | (Int
num, CharacterCategory
c) <- [(Int, CharacterCategory)]
xs
      , Int
num Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      ]
    categoryToString :: CharacterCategory -> String
    categoryToString :: CharacterCategory -> String
categoryToString CharacterCategory
category = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (CharacterCategory -> Char -> Bool
categoryToPredicate CharacterCategory
category) String
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 :: PasswordPolicy -> Q Exp
validatePasswordPolicyTH PasswordPolicy
pp =
    ([InvalidPolicyReason] -> Q Exp)
-> (ValidPasswordPolicy -> Q Exp)
-> Either [InvalidPolicyReason] ValidPasswordPolicy
-> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp)
-> ([InvalidPolicyReason] -> String)
-> [InvalidPolicyReason]
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InvalidPolicyReason] -> String
forall a. Show a => a -> String
showReasons) ValidPasswordPolicy -> Q Exp
forall p. p -> Q Exp
go (Either [InvalidPolicyReason] ValidPasswordPolicy -> Q Exp)
-> Either [InvalidPolicyReason] ValidPasswordPolicy -> Q Exp
forall a b. (a -> b) -> a -> b
$ PasswordPolicy -> Either [InvalidPolicyReason] ValidPasswordPolicy
validatePasswordPolicy PasswordPolicy
withDefault
  where
    withDefault :: PasswordPolicy
withDefault = PasswordPolicy
pp{charSetPredicate :: CharSetPredicate
charSetPredicate = CharSetPredicate
defaultCharSetPredicate}
    showReasons :: a -> String
showReasons a
rs = String
"Bad password policy: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
rs
    go :: p -> Q Exp
go p
_ = [|VPP|] Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
newPP
    allButCSPQ :: [Q Exp]
allButCSPQ = Int -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Int -> Q Exp) -> [Int] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordPolicy -> [Int]
allButCSP PasswordPolicy
withDefault
    newPP :: Q Exp
newPP = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
appE [|PasswordPolicy|] [Q Exp]
allButCSPQ Q Exp -> Q Exp -> Q Exp
`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 :: PasswordPolicy -> Either [InvalidPolicyReason] ValidPasswordPolicy
validatePasswordPolicy policy :: PasswordPolicy
policy@PasswordPolicy{Int
CharSetPredicate
charSetPredicate :: CharSetPredicate
digitChars :: Int
specialChars :: Int
lowercaseChars :: Int
uppercaseChars :: Int
maximumLength :: Int
minimumLength :: Int
charSetPredicate :: PasswordPolicy -> CharSetPredicate
digitChars :: PasswordPolicy -> Int
specialChars :: PasswordPolicy -> Int
lowercaseChars :: PasswordPolicy -> Int
uppercaseChars :: PasswordPolicy -> Int
maximumLength :: PasswordPolicy -> Int
minimumLength :: PasswordPolicy -> Int
..} =
    case [InvalidPolicyReason]
allReasons of
      [] -> ValidPasswordPolicy
-> Either [InvalidPolicyReason] ValidPasswordPolicy
forall a b. b -> Either a b
Right (ValidPasswordPolicy
 -> Either [InvalidPolicyReason] ValidPasswordPolicy)
-> ValidPasswordPolicy
-> Either [InvalidPolicyReason] ValidPasswordPolicy
forall a b. (a -> b) -> a -> b
$ PasswordPolicy -> ValidPasswordPolicy
VPP PasswordPolicy
policy
      [InvalidPolicyReason]
_ -> [InvalidPolicyReason]
-> Either [InvalidPolicyReason] ValidPasswordPolicy
forall a b. a -> Either a b
Left [InvalidPolicyReason]
allReasons
  where
    allReasons :: [InvalidPolicyReason]
allReasons = [[InvalidPolicyReason]] -> [InvalidPolicyReason]
forall a. Monoid a => [a] -> a
mconcat [[InvalidPolicyReason]
validMaxLength, [InvalidPolicyReason]
validLength, [InvalidPolicyReason]
validCategoryAmount, [InvalidPolicyReason]
validPredicate]
    validLength, validMaxLength, validCategoryAmount, validPredicate :: [InvalidPolicyReason]
    validLength :: [InvalidPolicyReason]
validLength =
        [Int -> Int -> InvalidPolicyReason
InvalidLength Int
minimumLength Int
maximumLength | Int
minimumLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maximumLength]
    validMaxLength :: [InvalidPolicyReason]
validMaxLength =
        [Int -> InvalidPolicyReason
MaxLengthBelowZero Int
maximumLength | Int
maximumLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0]
    validCategoryAmount :: [InvalidPolicyReason]
validCategoryAmount =
        -- We don't report this reason if the maximumLength is already invalid
        [Int -> Int -> InvalidPolicyReason
CategoryAmountsAboveMaxLength Int
maximumLength Int
total | Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maximumLength, Int
maximumLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]
      where
        capToZero :: Int -> Int
capToZero = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0
        total :: Int
total = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
capToZero (Int -> Int) -> [Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
lowercaseChars, Int
uppercaseChars, Int
digitChars, Int
specialChars]
    validPredicate :: [InvalidPolicyReason]
validPredicate = PasswordPolicy -> [InvalidPolicyReason]
validateCharSetPredicate PasswordPolicy
policy

-- @since 2.1.0.0
-- | Default character set
--
-- Should be all non-control characters in the ASCII character set.
defaultCharSet :: String
defaultCharSet :: String
defaultCharSet = Int -> Char
chr (Int -> Char) -> [Int] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
32 .. Int
126]