{-# 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.Keyboard (
  -- * Keyboard Pattern Matching
  KeyboardPattern,
  keyboardToken,
  keyboardPattern,
  keyboardEstimate
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens (Lens, (^.), _3)
import Data.Foldable (foldl')
import Numeric.SpecFunctions (choose)

--------------------------------------------------------------------------------
-- Project Imports:
import Text.Password.Strength.Internal.Adjacency
import Text.Password.Strength.Internal.Token
import Text.Password.Strength.Internal.Math (variations')

--------------------------------------------------------------------------------
-- | Information about a found pattern.
newtype KeyboardPattern =
  KeyboardPattern (Int, Int, Token, AdjacencyScore)
  deriving (Int -> KeyboardPattern -> ShowS
[KeyboardPattern] -> ShowS
KeyboardPattern -> String
(Int -> KeyboardPattern -> ShowS)
-> (KeyboardPattern -> String)
-> ([KeyboardPattern] -> ShowS)
-> Show KeyboardPattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyboardPattern] -> ShowS
$cshowList :: [KeyboardPattern] -> ShowS
show :: KeyboardPattern -> String
$cshow :: KeyboardPattern -> String
showsPrec :: Int -> KeyboardPattern -> ShowS
$cshowsPrec :: Int -> KeyboardPattern -> ShowS
Show)

--------------------------------------------------------------------------------
-- | Allow other code to access the token used in a pattern.
keyboardToken :: Lens KeyboardPattern KeyboardPattern Token Token
keyboardToken :: (Token -> f Token) -> KeyboardPattern -> f KeyboardPattern
keyboardToken Token -> f Token
f (KeyboardPattern (Int, Int, Token, AdjacencyScore)
t) = (Int, Int, Token, AdjacencyScore) -> KeyboardPattern
KeyboardPattern ((Int, Int, Token, AdjacencyScore) -> KeyboardPattern)
-> f (Int, Int, Token, AdjacencyScore) -> f KeyboardPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> f Token)
-> (Int, Int, Token, AdjacencyScore)
-> f (Int, Int, Token, AdjacencyScore)
forall s t a b. Field3 s t a b => Lens s t a b
_3 Token -> f Token
f (Int, Int, Token, AdjacencyScore)
t

--------------------------------------------------------------------------------
-- | Helper function to check if a token forms a keyboard pattern.
keyboardPattern :: AdjacencyTable -> Token -> Maybe KeyboardPattern
keyboardPattern :: AdjacencyTable -> Token -> Maybe KeyboardPattern
keyboardPattern AdjacencyTable
graph Token
token = (Int, Int, Token, AdjacencyScore) -> KeyboardPattern
KeyboardPattern ((Int, Int, Token, AdjacencyScore) -> KeyboardPattern)
-> (NonEmpty Adjacency -> (Int, Int, Token, AdjacencyScore))
-> NonEmpty Adjacency
-> KeyboardPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (AdjacencyTable
graph AdjacencyTable -> Getting Int AdjacencyTable Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyTable Int
Lens' AdjacencyTable Int
totalChars, AdjacencyTable
graph AdjacencyTable -> Getting Int AdjacencyTable Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyTable Int
Lens' AdjacencyTable Int
averageNeighbors, Token
token,) (AdjacencyScore -> (Int, Int, Token, AdjacencyScore))
-> (NonEmpty Adjacency -> AdjacencyScore)
-> NonEmpty Adjacency
-> (Int, Int, Token, AdjacencyScore)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (AdjacencyScore -> Adjacency -> AdjacencyScore)
-> AdjacencyScore -> NonEmpty Adjacency -> AdjacencyScore
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' AdjacencyScore -> Adjacency -> AdjacencyScore
scoreSequence AdjacencyScore
forall a. Monoid a => a
mempty (NonEmpty Adjacency -> KeyboardPattern)
-> Maybe (NonEmpty Adjacency) -> Maybe KeyboardPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> AdjacencyTable -> Maybe (NonEmpty Adjacency)
findSequence (Token
token Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenChars) AdjacencyTable
graph

--------------------------------------------------------------------------------
-- | Estimate the number of guesses needed for a keyboard pattern to
-- be cracked.
keyboardEstimate :: KeyboardPattern -> Integer
keyboardEstimate :: KeyboardPattern -> Integer
keyboardEstimate (KeyboardPattern (Int
s, Int
d, Token
_, AdjacencyScore
a)) =
    Integer
e3 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Int -> Integer
e2 (AdjacencyScore
a AdjacencyScore -> Getting Int AdjacencyScore Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyScore Int
Lens' AdjacencyScore Int
primaryLayer) (AdjacencyScore
a AdjacencyScore -> Getting Int AdjacencyScore Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyScore Int
Lens' AdjacencyScore Int
secondaryLayer)

  where
    -- Equation 3, section 4, page 163 (8/18)
    --
    -- Deviations from the paper or other implementations:
    --
    --   * There's a typo in the paper: min(T, i - i)
    --     but should be: min(T, i - 1)
    --
    --   * Another typo, i should start at 2 and not 1.
    --
    --   * The other implementations don't seem to divide the outer
    --     sum by two but the equation clearly does.
    e3 :: Integer
    e3 :: Integer
e3 = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer)
-> ([Integer] -> Integer) -> [Integer] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) (Integer -> Integer)
-> ([Integer] -> Integer) -> [Integer] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ do
      Int
i <- [Int
2 .. (AdjacencyScore
a AdjacencyScore -> Getting Int AdjacencyScore Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyScore Int
Lens' AdjacencyScore Int
patternLength)]
      Int
j <- [Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (AdjacencyScore
a AdjacencyScore -> Getting Int AdjacencyScore Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyScore Int
Lens' AdjacencyScore Int
totalTurns) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
      Integer -> [Integer]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> [Integer]) -> Integer -> [Integer]
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Int -> Int -> Double
choose (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
d Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
j)

    -- Modified version of equation 2 for primary layer vs. secondary.
    e2 :: Int -> Int -> Integer
    e2 :: Int -> Int -> Integer
e2 = Int -> Int -> Integer
variations'