{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Password.Validate
(
validatePassword,
isValidPassword,
ValidationResult(..),
validatePasswordPolicy,
validatePasswordPolicyTH,
PasswordPolicy (..),
ValidPasswordPolicy,
fromValidPasswordPolicy,
defaultPasswordPolicy,
defaultPasswordPolicy_,
CharSetPredicate(..),
defaultCharSetPredicate,
InvalidReason (..),
InvalidPolicyReason(..),
CharacterCategory(..),
MinimumLength,
MaximumLength,
ProvidedLength,
MinimumAmount,
ProvidedAmount,
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)
data PasswordPolicy = PasswordPolicy
{ PasswordPolicy -> Int
minimumLength :: !Int
, PasswordPolicy -> Int
maximumLength :: !Int
, PasswordPolicy -> Int
uppercaseChars :: !Int
, PasswordPolicy -> Int
lowercaseChars :: !Int
, PasswordPolicy -> Int
specialChars :: !Int
, PasswordPolicy -> Int
digitChars :: !Int
, PasswordPolicy -> CharSetPredicate
charSetPredicate :: CharSetPredicate
}
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
]
instance Eq PasswordPolicy where
== :: PasswordPolicy -> PasswordPolicy -> Bool
(==) = forall {b}. Eq b => [b] -> [b] -> Bool
go forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PasswordPolicy -> [Int]
allButCSP
where
go :: [b] -> [b] -> Bool
go [b]
a [b]
b = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==) [b]
a [b]
b
instance Ord PasswordPolicy where
compare :: PasswordPolicy -> PasswordPolicy -> Ordering
compare = forall {b}. Ord b => [b] -> [b] -> Ordering
go forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PasswordPolicy -> [Int]
allButCSP
where
go :: [b] -> [b] -> Ordering
go [b]
a [b]
b = [Ordering] -> Ordering
check forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Ordering
compare [b]
a [b]
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
..} = forall a. Monoid a => [a] -> a
mconcat
[ String
"PasswordPolicy {"
, String
"minimumLength = ", forall a. Show a => a -> String
show Int
minimumLength
, String
", maximumLength = ", forall a. Show a => a -> String
show Int
maximumLength
, String
", uppercaseChars = ", forall a. Show a => a -> String
show Int
uppercaseChars
, String
", lowercaseChars = ", forall a. Show a => a -> String
show Int
lowercaseChars
, String
", specialChars = ", forall a. Show a => a -> String
show Int
specialChars
, String
", digitChars = ", forall a. Show a => a -> String
show Int
digitChars
, String
", charSetPredicate = <FUNCTION>}"
]
newtype ValidPasswordPolicy = VPP
{ ValidPasswordPolicy -> PasswordPolicy
fromValidPasswordPolicy :: PasswordPolicy
} deriving (ValidPasswordPolicy -> ValidPasswordPolicy -> Bool
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
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
Ord, Int -> ValidPasswordPolicy -> ShowS
[ValidPasswordPolicy] -> ShowS
ValidPasswordPolicy -> String
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)
defaultPasswordPolicy :: PasswordPolicy
defaultPasswordPolicy :: PasswordPolicy
defaultPasswordPolicy = 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
}
defaultPasswordPolicy_ :: ValidPasswordPolicy
defaultPasswordPolicy_ :: ValidPasswordPolicy
defaultPasswordPolicy_ = PasswordPolicy -> ValidPasswordPolicy
VPP PasswordPolicy
defaultPasswordPolicy
newtype CharSetPredicate = CharSetPredicate
{ CharSetPredicate -> Char -> Bool
getCharSetPredicate :: Char -> Bool
}
defaultCharSetPredicate :: CharSetPredicate
defaultCharSetPredicate :: CharSetPredicate
defaultCharSetPredicate = (Char -> Bool) -> CharSetPredicate
CharSetPredicate forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
>= Int
32 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
<= Int
126
{-# INLINE defaultCharSetPredicate #-}
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
data CharacterCategory
= Uppercase
| Lowercase
| Special
| Digit
deriving (CharacterCategory -> CharacterCategory -> Bool
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
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
Ord, Int -> CharacterCategory -> ShowS
[CharacterCategory] -> ShowS
CharacterCategory -> String
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)
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
data InvalidReason
= PasswordTooShort !MinimumLength !ProvidedLength
| PasswordTooLong !MaximumLength !ProvidedLength
| NotEnoughReqChars !CharacterCategory !MinimumAmount !ProvidedAmount
| InvalidCharacters !Text
deriving (InvalidReason -> InvalidReason -> Bool
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
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
Ord, Int -> InvalidReason -> ShowS
[InvalidReason] -> ShowS
InvalidReason -> String
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)
data InvalidPolicyReason
= InvalidLength !MinimumLength !MaximumLength
| MaxLengthBelowZero !MaximumLength
| CategoryAmountsAboveMaxLength !MaximumLength !Int
| InvalidCharSetPredicate !CharacterCategory !MinimumAmount
deriving (InvalidPolicyReason -> InvalidPolicyReason -> Bool
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
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
Ord, Int -> InvalidPolicyReason -> ShowS
[InvalidPolicyReason] -> ShowS
InvalidPolicyReason -> String
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)
data ValidationResult = ValidPassword | InvalidPassword [InvalidReason]
deriving (ValidationResult -> ValidationResult -> Bool
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
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)
isValidPassword :: ValidPasswordPolicy -> Password -> Bool
isValidPassword :: ValidPasswordPolicy -> Password -> Bool
isValidPassword ValidPasswordPolicy
policy Password
pass = ValidPasswordPolicy -> Password -> ValidationResult
validatePassword ValidPasswordPolicy
policy Password
pass forall a. Eq a => a -> a -> Bool
== ValidationResult
ValidPassword
{-# INLINE isValidPassword #-}
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 = 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 forall a. Ord a => a -> a -> Bool
> Int
maximumLength]
isTooShort :: [InvalidReason]
isTooShort = [Int -> Int -> InvalidReason
PasswordTooShort Int
minimumLength Int
len | Int
len 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
predicate) Text
password
in [Text -> InvalidReason
InvalidCharacters Text
filteredText | Bool -> Bool
not 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 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 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 forall a. Ord a => a -> a -> Bool
< Int
requiredCharNum
]
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 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 forall a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> a -> Bool
> Int
0
]
categoryToString :: CharacterCategory -> String
categoryToString :: CharacterCategory -> String
categoryToString CharacterCategory
category = forall a. (a -> Bool) -> [a] -> [a]
filter (CharacterCategory -> Char -> Bool
categoryToPredicate CharacterCategory
category) String
defaultCharSet
validatePasswordPolicyTH :: PasswordPolicy -> Q Exp
validatePasswordPolicyTH :: PasswordPolicy -> Q Exp
validatePasswordPolicyTH PasswordPolicy
pp =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
showReasons) forall {p}. p -> Q Exp
go 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: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
rs
go :: p -> Q Exp
go p
_ = [|VPP|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
newPP
allButCSPQ :: [Q Exp]
allButCSPQ = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordPolicy -> [Int]
allButCSP PasswordPolicy
withDefault
newPP :: Q Exp
newPP = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|PasswordPolicy|] [Q Exp]
allButCSPQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [|defaultCharSetPredicate|]
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
[] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PasswordPolicy -> ValidPasswordPolicy
VPP PasswordPolicy
policy
[InvalidPolicyReason]
_ -> forall a b. a -> Either a b
Left [InvalidPolicyReason]
allReasons
where
allReasons :: [InvalidPolicyReason]
allReasons = 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 forall a. Ord a => a -> a -> Bool
> Int
maximumLength]
validMaxLength :: [InvalidPolicyReason]
validMaxLength =
[Int -> InvalidPolicyReason
MaxLengthBelowZero Int
maximumLength | Int
maximumLength forall a. Ord a => a -> a -> Bool
<= Int
0]
validCategoryAmount :: [InvalidPolicyReason]
validCategoryAmount =
[Int -> Int -> InvalidPolicyReason
CategoryAmountsAboveMaxLength Int
maximumLength Int
total | Int
total forall a. Ord a => a -> a -> Bool
> Int
maximumLength, Int
maximumLength forall a. Ord a => a -> a -> Bool
> Int
0]
where
capToZero :: Int -> Int
capToZero = forall a. Ord a => a -> a -> a
max Int
0
total :: Int
total = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ Int -> Int
capToZero 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
defaultCharSet :: String
defaultCharSet :: String
defaultCharSet = Int -> Char
chr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
32 .. Int
126]