{-|

Copyright:
  This file is part of the package zxcvbn-hs. It is subject to the
  license terms in the LICENSE file found in the top-level directory
  of this distribution and at:

    https://code.devalot.com/sthenauth/zxcvbn-hs

  No part of this package, including this file, may be copied,
  modified, propagated, or distributed except according to the terms
  contained in the LICENSE file.

License: MIT

-}
module Text.Password.Strength.Internal.Repeat (
  -- * Repeating Token Matches
  RepeatMap,
  Repeat,
  mkRepeatMap,
  repeatMatch
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Arrow ((&&&))
import Control.Lens ((^.), _1)
import Data.Function (on)
import Data.List (sortBy, subsequences, maximumBy)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text

--------------------------------------------------------------------------------
-- Project Imports:
import Text.Password.Strength.Internal.Token

--------------------------------------------------------------------------------
-- | Internal mapping of repeating tokens.
newtype RepeatMap = RepeatMap
  { RepeatMap -> Map Text [Token]
getMap :: Map Text [Token] }

--------------------------------------------------------------------------------
-- | Type alias for a count of repeating tokens.
type Repeat = Int

--------------------------------------------------------------------------------
-- | Generate a repeat map from an existing token map.
mkRepeatMap :: Map Token a -> RepeatMap
mkRepeatMap :: Map Token a -> RepeatMap
mkRepeatMap = Map Text [Token] -> RepeatMap
RepeatMap (Map Text [Token] -> RepeatMap)
-> (Map Token a -> Map Text [Token]) -> Map Token a -> RepeatMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> a -> Map Text [Token] -> Map Text [Token])
-> Map Text [Token] -> Map Token a -> Map Text [Token]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Token -> a -> Map Text [Token] -> Map Text [Token]
forall p. Token -> p -> Map Text [Token] -> Map Text [Token]
f Map Text [Token]
forall k a. Map k a
Map.empty
  where f :: Token -> p -> Map Text [Token] -> Map Text [Token]
f Token
t p
_ = ([Token] -> [Token] -> [Token])
-> Text -> [Token] -> Map Text [Token] -> Map Text [Token]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
(<>) (Token
t Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenChars) [Token
t]

--------------------------------------------------------------------------------
-- | Test to see if the given token is repeated.
--
-- If a repeat is found, the number of occurrences is returned along
-- with the full token representing the repeating sequence.
--
-- In other words, if the token passed in is "word" and in the map we
-- find that the original password contains "wordword", we return 2 to
-- indicate 2 repeats and the token that represents the sequence
-- "wordword".
repeatMatch :: RepeatMap -> Token -> Maybe (Repeat, Token)
repeatMatch :: RepeatMap -> Token -> Maybe (Repeat, Token)
repeatMatch RepeatMap
m Token
t =
    Text -> Map Text [Token] -> Maybe [Token]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Token
t Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenChars) (RepeatMap -> Map Text [Token]
getMap RepeatMap
m) Maybe [Token] -> ([Token] -> Maybe [Token]) -> Maybe [Token]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      [Token] -> Maybe [Token]
ordered Maybe [Token]
-> ([Token] -> Maybe (Repeat, [Token])) -> Maybe (Repeat, [Token])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        [Token] -> Maybe (Repeat, [Token])
longestSequence Maybe (Repeat, [Token])
-> ((Repeat, [Token]) -> Maybe (Repeat, Token))
-> Maybe (Repeat, Token)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          (Repeat, [Token]) -> Maybe (Repeat, Token)
mkToken
  where
    ordered :: [Token] -> Maybe [Token]
    ordered :: [Token] -> Maybe [Token]
ordered []  = Maybe [Token]
forall a. Maybe a
Nothing
    ordered [Token
_] = Maybe [Token]
forall a. Maybe a
Nothing -- Must have at least two elements to repeat.
    ordered [Token]
xs  = [Token] -> Maybe [Token]
forall a. a -> Maybe a
Just ([Token] -> Maybe [Token]) -> [Token] -> Maybe [Token]
forall a b. (a -> b) -> a -> b
$ (Token -> Token -> Ordering) -> [Token] -> [Token]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Repeat -> Repeat -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Repeat -> Repeat -> Ordering)
-> (Token -> Repeat) -> Token -> Token -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Token -> Getting Repeat Token Repeat -> Repeat
forall s a. s -> Getting a s a -> a
^. Getting Repeat Token Repeat
Lens' Token Repeat
startIndex)) [Token]
xs

    longestSequence :: [Token] -> Maybe (Repeat, [Token])
    longestSequence :: [Token] -> Maybe (Repeat, [Token])
longestSequence [Token]
ts =
      let f :: [Token] -> [(Repeat, [Token])]
f = ((Repeat, [Token]) -> Bool)
-> [(Repeat, [Token])] -> [(Repeat, [Token])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Repeat
n,[Token]
_) -> Repeat
n Repeat -> Repeat -> Bool
forall a. Ord a => a -> a -> Bool
>= Repeat
2) ([(Repeat, [Token])] -> [(Repeat, [Token])])
-> ([Token] -> [(Repeat, [Token])])
-> [Token]
-> [(Repeat, [Token])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                ([Token] -> (Repeat, [Token])) -> [[Token]] -> [(Repeat, [Token])]
forall a b. (a -> b) -> [a] -> [b]
map ([Token] -> Repeat
forall (t :: * -> *) a. Foldable t => t a -> Repeat
length ([Token] -> Repeat)
-> ([Token] -> [Token]) -> [Token] -> (Repeat, [Token])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Token] -> [Token]
forall a. a -> a
id) ([[Token]] -> [(Repeat, [Token])])
-> ([Token] -> [[Token]]) -> [Token] -> [(Repeat, [Token])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  ([Token] -> Bool) -> [[Token]] -> [[Token]]
forall a. (a -> Bool) -> [a] -> [a]
filter (((Token, Token) -> Bool) -> [(Token, Token)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Token, Token) -> Bool
isSequence ([(Token, Token)] -> Bool)
-> ([Token] -> [(Token, Token)]) -> [Token] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [(Token, Token)]
lineUp) ([[Token]] -> [[Token]])
-> ([Token] -> [[Token]]) -> [Token] -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    [Token] -> [[Token]]
forall a. [a] -> [[a]]
subsequences
      in case [Token] -> [(Repeat, [Token])]
f [Token]
ts of
        [] -> Maybe (Repeat, [Token])
forall a. Maybe a
Nothing
        [(Repeat, [Token])]
xs -> (Repeat, [Token]) -> Maybe (Repeat, [Token])
forall a. a -> Maybe a
Just ((Repeat, [Token]) -> Maybe (Repeat, [Token]))
-> (Repeat, [Token]) -> Maybe (Repeat, [Token])
forall a b. (a -> b) -> a -> b
$ ((Repeat, [Token]) -> (Repeat, [Token]) -> Ordering)
-> [(Repeat, [Token])] -> (Repeat, [Token])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (Repeat -> Repeat -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Repeat -> Repeat -> Ordering)
-> ((Repeat, [Token]) -> Repeat)
-> (Repeat, [Token])
-> (Repeat, [Token])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Repeat, [Token])
-> Getting Repeat (Repeat, [Token]) Repeat -> Repeat
forall s a. s -> Getting a s a -> a
^. Getting Repeat (Repeat, [Token]) Repeat
forall s t a b. Field1 s t a b => Lens s t a b
_1)) [(Repeat, [Token])]
xs

    mkToken :: (Repeat, [Token]) -> Maybe (Repeat, Token)
    mkToken :: (Repeat, [Token]) -> Maybe (Repeat, Token)
mkToken (Repeat
_, []) = Maybe (Repeat, Token)
forall a. Maybe a
Nothing
    mkToken (Repeat
n, [Token]
ts) = (Repeat, Token) -> Maybe (Repeat, Token)
forall a. a -> Maybe a
Just ((Repeat, Token) -> Maybe (Repeat, Token))
-> (Repeat, Token) -> Maybe (Repeat, Token)
forall a b. (a -> b) -> a -> b
$
      let s :: Repeat
s = [Token] -> Token
forall a. [a] -> a
head [Token]
ts Token -> Getting Repeat Token Repeat -> Repeat
forall s a. s -> Getting a s a -> a
^. Getting Repeat Token Repeat
Lens' Token Repeat
startIndex
          e :: Repeat
e = [Token] -> Token
forall a. [a] -> a
last [Token]
ts Token -> Getting Repeat Token Repeat -> Repeat
forall s a. s -> Getting a s a -> a
^. Getting Repeat Token Repeat
Lens' Token Repeat
endIndex
          c :: Text
c = Repeat -> Text -> Text
Text.replicate Repeat
n (Token
t Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenChars)
          l :: Text
l = Repeat -> Text -> Text
Text.replicate Repeat
n (Token
t Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenLower)
      in (Repeat
n, Text -> Text -> Repeat -> Repeat -> Token
Token Text
c Text
l Repeat
s Repeat
e)

    lineUp :: [Token] -> [(Token, Token)]
    lineUp :: [Token] -> [(Token, Token)]
lineUp [Token]
xs = [Token] -> [Token] -> [(Token, Token)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Token]
xs (Repeat -> [Token] -> [Token]
forall a. Repeat -> [a] -> [a]
drop Repeat
1 [Token]
xs)

    isSequence :: (Token, Token) -> Bool
    isSequence :: (Token, Token) -> Bool
isSequence (Token
x, Token
y) = (Token
y Token -> Getting Repeat Token Repeat -> Repeat
forall s a. s -> Getting a s a -> a
^. Getting Repeat Token Repeat
Lens' Token Repeat
startIndex) Repeat -> Repeat -> Repeat
forall a. Num a => a -> a -> a
- (Token
x Token -> Getting Repeat Token Repeat -> Repeat
forall s a. s -> Getting a s a -> a
^. Getting Repeat Token Repeat
Lens' Token Repeat
endIndex) Repeat -> Repeat -> Bool
forall a. Eq a => a -> a -> Bool
== Repeat
1