{-# 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 Rank -> Match -> ShowS
[Match] -> ShowS
Match -> String
forall a.
(Rank -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Match] -> ShowS
$cshowList :: [Match] -> ShowS
show :: Match -> String
$cshow :: Match -> String
showsPrec :: Rank -> Match -> ShowS
$cshowsPrec :: Rank -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Token
t -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Token
t (Token -> [Match]
check Token
t)) forall k a. Map k a
Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Text -> [Token]
allTokens
  where
    check :: Token -> [Match]
    check :: Token -> [Match]
check Token
t = 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]
      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 = Rank -> Match
DictionaryMatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Config -> (a -> Text) -> a -> Maybe Rank
rank Config
cfg (forall s a. s -> Getting a s a -> a
^. 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 = Rank -> Match
ReverseDictionaryMatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall a. Config -> (a -> Text) -> a -> Maybe Rank
rank Config
cfg (forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views 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 (Rank, L33t)
rnk L33t
l = (,L33t
l) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Config -> (a -> Text) -> a -> Maybe Rank
rank Config
cfg (forall s a. s -> Getting a s a -> a
^. Lens' L33t Text
l33tText) L33t
l
      in forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Rank -> L33t -> Match
L33tMatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           forall a s.
Getting (Endo (Endo (Maybe a))) s a
-> (a -> a -> Ordering) -> s -> Maybe a
minimumByOf forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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))
                                (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe L33t -> Maybe (Rank, 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AdjacencyTable -> Token -> Maybe KeyboardPattern
`keyboardPattern` Token
t)
                (Config
cfg forall s a. s -> Getting a s a -> a
^. 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 = Rank -> Match
SequenceMatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Rank
isSequence (Token
t forall s a. s -> Getting a s a -> a
^. 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> Text -> Maybe Date
isDate Day
day (Token
t forall s a. s -> Getting a s a -> a
^. 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 = forall a. Map Token a -> RepeatMap
mkRepeatMap Matches
ms
          f :: Token -> Maybe (Token, [Match])
f Token
t = (\(Rank
n, Token
t') -> (Token
t', [Rank -> Token -> Match
RepeatMatch Rank
n Token
t])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RepeatMap -> Token -> Maybe (Rank, Token)
repeatMatch RepeatMap
rmap Token
t
          g :: Token -> Matches -> Matches
g Token
t Matches
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Matches
m (\(Token
k,[Match]
v) -> 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
k [Match]
v Matches
m) (Token -> Maybe (Token, [Match])
f Token
t)
      in forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Matches -> Matches
g) Matches
ms Matches
ms