{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE TupleSections   #-}

{-|

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.Match (
  -- * Matching Tokens Against Known Patterns
  Match(..),
  Matches,
  matches
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((^.), _1, views, minimumByOf)
import Data.Function (on)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe, catMaybes)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (Day)

--------------------------------------------------------------------------------
-- Project Imports:
import Text.Password.Strength.Internal.Config
import Text.Password.Strength.Internal.Date
import Text.Password.Strength.Internal.Dictionary
import Text.Password.Strength.Internal.Keyboard
import Text.Password.Strength.Internal.L33t
import Text.Password.Strength.Internal.Repeat
import Text.Password.Strength.Internal.Sequence
import Text.Password.Strength.Internal.Token

--------------------------------------------------------------------------------
-- | The known patterns we are searching for.
data Match
  = DictionaryMatch Rank
    -- ^ The associated token was found in a frequency dictionary with
    -- the specified rank.

  | ReverseDictionaryMatch Rank
    -- ^ The associated token was found in a frequency dictionary, but
    -- only after its characters were reversed.

  | L33tMatch Rank L33t
    -- ^ The associated token was found in a frequency dictionary, but
    -- only after its characters were translated from l33t speak to
    -- English.

  | KeyboardMatch KeyboardPattern
    -- ^ The associated token is wholly made up of an adjacent
    -- sequence of characters that make a pattern on a keyboard.

  | SequenceMatch Delta
    -- ^ The characters of the associated token form a sequence
    -- because the delta between all the characters is the same.
    --
    -- Examples:
    --
    --   * abc
    ---  * 135

  | DateMatch Date
    -- ^ The associated token wholly contains a date.

  | RepeatMatch Repeat Token
    -- ^ The associated token is an adjacent repeat of another token
    -- (the one given to this constructor).  The number of times it
    -- repeats is given as 'Repeat'.

  deriving Int -> Match -> ShowS
[Match] -> ShowS
Match -> String
(Int -> Match -> ShowS)
-> (Match -> String) -> ([Match] -> ShowS) -> Show Match
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Match] -> ShowS
$cshowList :: [Match] -> ShowS
show :: Match -> String
$cshow :: Match -> String
showsPrec :: Int -> Match -> ShowS
$cshowsPrec :: Int -> Match -> ShowS
Show

--------------------------------------------------------------------------------
-- | Information about how a token matches a specific match pattern.
type Matches = Map Token [Match]

--------------------------------------------------------------------------------
-- | All possible matches after various transformations.
matches :: Config -> Day -> Text -> Matches
matches :: Config -> Day -> Text -> Matches
matches Config
cfg Day
day =
    Matches -> Matches
repeats (Matches -> Matches) -> (Text -> Matches) -> Text -> Matches
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Token -> Matches -> Matches) -> Matches -> [Token] -> Matches
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Token
t -> Token -> [Match] -> Matches -> Matches
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Token
t (Token -> [Match]
check Token
t)) Matches
forall k a. Map k a
Map.empty ([Token] -> Matches) -> (Text -> [Token]) -> Text -> Matches
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Text -> [Token]
allTokens
  where
    check :: Token -> [Match]
    check :: Token -> [Match]
check Token
t = [Maybe Match] -> [Match]
forall a. [Maybe a] -> [a]
catMaybes
      [Token -> Maybe Match
dict Token
t, Token -> Maybe Match
rdict Token
t, Token -> Maybe Match
l33ts Token
t, Token -> Maybe Match
seqMatch Token
t, Token -> Maybe Match
dateMatch Token
t]
      [Match] -> [Match] -> [Match]
forall a. [a] -> [a] -> [a]
++ Token -> [Match]
kbd Token
t

    -- Tokens that appear in a dictionary.
    dict :: Token -> Maybe Match
    dict :: Token -> Maybe Match
dict Token
t = Int -> Match
DictionaryMatch (Int -> Match) -> Maybe Int -> Maybe Match
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> (Token -> Text) -> Token -> Maybe Int
forall a. Config -> (a -> Text) -> a -> Maybe Int
rank Config
cfg (Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenLower) Token
t

    -- Tokens that, when reversed, appear in a dictionary.
    rdict :: Token -> Maybe Match
    rdict :: Token -> Maybe Match
rdict Token
t = Int -> Match
ReverseDictionaryMatch (Int -> Match) -> Maybe Int -> Maybe Match
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Config -> (Token -> Text) -> Token -> Maybe Int
forall a. Config -> (a -> Text) -> a -> Maybe Int
rank Config
cfg (Getting Text Token Text -> (Text -> Text) -> Token -> Text
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views Getting Text Token Text
Lens' Token Text
tokenLower Text -> Text
Text.reverse) Token
t

    -- Tokens that, when decoded, appear in a dictionary.
    --
    -- A token may l33t decode into several words that are then looked
    -- up in the word dictionaries.  The word with the lowest rank is
    -- kept and the others are discarded.
    l33ts :: Token -> Maybe Match
    l33ts :: Token -> Maybe Match
l33ts Token
t =
      let ts :: [L33t]
ts = Token -> [L33t]
l33t Token
t -- Decoding may result in multiple outputs.
          rnk :: L33t -> Maybe (Int, L33t)
rnk L33t
l = (,L33t
l) (Int -> (Int, L33t)) -> Maybe Int -> Maybe (Int, L33t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> (L33t -> Text) -> L33t -> Maybe Int
forall a. Config -> (a -> Text) -> a -> Maybe Int
rank Config
cfg (L33t -> Getting Text L33t Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text L33t Text
Lens' L33t Text
l33tText) L33t
l
      in (Int -> L33t -> Match) -> (Int, L33t) -> Match
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> L33t -> Match
L33tMatch ((Int, L33t) -> Match) -> Maybe (Int, L33t) -> Maybe Match
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           Getting (Endo (Endo (Maybe (Int, L33t)))) [(Int, L33t)] (Int, L33t)
-> ((Int, L33t) -> (Int, L33t) -> Ordering)
-> [(Int, L33t)]
-> Maybe (Int, L33t)
forall a s.
Getting (Endo (Endo (Maybe a))) s a
-> (a -> a -> Ordering) -> s -> Maybe a
minimumByOf Getting (Endo (Endo (Maybe (Int, L33t)))) [(Int, L33t)] (Int, L33t)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, L33t) -> Int) -> (Int, L33t) -> (Int, L33t) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Int, L33t) -> Getting Int (Int, L33t) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, L33t) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1))
                                ((L33t -> Maybe (Int, L33t)) -> [L33t] -> [(Int, L33t)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe L33t -> Maybe (Int, L33t)
rnk [L33t]
ts)

    -- A token that is a pattern on one or more keyboards.
    kbd :: Token -> [Match]
    kbd :: Token -> [Match]
kbd Token
t = KeyboardPattern -> Match
KeyboardMatch (KeyboardPattern -> Match) -> [KeyboardPattern] -> [Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (AdjacencyTable -> Maybe KeyboardPattern)
-> [AdjacencyTable] -> [KeyboardPattern]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AdjacencyTable -> Token -> Maybe KeyboardPattern
`keyboardPattern` Token
t)
                (Config
cfg Config
-> Getting [AdjacencyTable] Config [AdjacencyTable]
-> [AdjacencyTable]
forall s a. s -> Getting a s a -> a
^. Getting [AdjacencyTable] Config [AdjacencyTable]
forall c. HasConfig c => Lens' c [AdjacencyTable]
keyboardGraphs)

    -- Characters in a token form a sequence.
    seqMatch :: Token -> Maybe Match
    seqMatch :: Token -> Maybe Match
seqMatch Token
t = Int -> Match
SequenceMatch (Int -> Match) -> Maybe Int -> Maybe Match
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
isSequence (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)

    -- Characters in a token form a date.
    dateMatch :: Token -> Maybe Match
    dateMatch :: Token -> Maybe Match
dateMatch Token
t = Date -> Match
DateMatch (Date -> Match) -> Maybe Date -> Maybe Match
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> Text -> Maybe Date
isDate Day
day (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)

    -- Tokens that are repeats of some other token.
    repeats :: Matches -> Matches
    repeats :: Matches -> Matches
repeats Matches
ms =
      let rmap :: RepeatMap
rmap = Matches -> RepeatMap
forall a. Map Token a -> RepeatMap
mkRepeatMap Matches
ms
          f :: Token -> Maybe (Token, [Match])
f Token
t = (\(Int
n, Token
t') -> (Token
t', [Int -> Token -> Match
RepeatMatch Int
n Token
t])) ((Int, Token) -> (Token, [Match]))
-> Maybe (Int, Token) -> Maybe (Token, [Match])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RepeatMap -> Token -> Maybe (Int, Token)
repeatMatch RepeatMap
rmap Token
t
          g :: Token -> Matches -> Matches
g Token
t Matches
m = Matches
-> ((Token, [Match]) -> Matches)
-> Maybe (Token, [Match])
-> Matches
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Matches
m (\(Token
k,[Match]
v) -> ([Match] -> [Match] -> [Match])
-> Token -> [Match] -> Matches -> Matches
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
(<>) Token
k [Match]
v Matches
m) (Token -> Maybe (Token, [Match])
f Token
t)
      in (Token -> [Match] -> Matches -> Matches)
-> Matches -> Matches -> Matches
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey ((Matches -> Matches) -> [Match] -> Matches -> Matches
forall a b. a -> b -> a
const ((Matches -> Matches) -> [Match] -> Matches -> Matches)
-> (Token -> Matches -> Matches)
-> Token
-> [Match]
-> Matches
-> Matches
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Matches -> Matches
g) Matches
ms Matches
ms