content: {-# 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.Types (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})
              p = getCharSetPredicate . charSetPredicate $ fromValidPasswordPolicy policy
              c = chr i
          in p 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
  