{-|

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 :: forall a. Map Token a -> RepeatMap
mkRepeatMap = Map Text [Token] -> RepeatMap
RepeatMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey forall {p}. Token -> p -> Map Text [Token] -> Map Text [Token]
f forall k a. Map k a
Map.empty
  where f :: Token -> p -> Map Text [Token] -> Map Text [Token]
f Token
t p
_ = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) (Token
t forall s a. s -> Getting a s a -> a
^. 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 (Int, Token)
repeatMatch RepeatMap
m Token
t =
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Token
t forall s a. s -> Getting a s a -> a
^. Lens' Token Text
tokenChars) (RepeatMap -> Map Text [Token]
getMap RepeatMap
m) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      [Token] -> Maybe [Token]
ordered forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        [Token] -> Maybe (Int, [Token])
longestSequence forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          (Int, [Token]) -> Maybe (Int, Token)
mkToken
  where
    ordered :: [Token] -> Maybe [Token]
    ordered :: [Token] -> Maybe [Token]
ordered []  = forall a. Maybe a
Nothing
    ordered [Token
_] = forall a. Maybe a
Nothing -- Must have at least two elements to repeat.
    ordered [Token]
xs  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall s a. s -> Getting a s a -> a
^. Lens' Token Int
startIndex)) [Token]
xs

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

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

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

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