{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE DeriveGeneric   #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

{-|

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.Adjacency (
  -- * Adjacency Matching (for Keyboard Patterns)
  Pattern,
  Direction(..),
  Move(..),
  Layer(..),
  Adjacency(..),
  AdjacencyTable(..),
  totalChars,
  averageNeighbors,
  patterns,
  findSequence,
  AdjacencyScore(..),
  patternLength,
  totalTurns,
  primaryLayer,
  secondaryLayer,
  scoreSequence
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((&), (^.), (+~), (.~))
import Control.Lens.TH (makeLenses)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Binary (Binary)
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)

--------------------------------------------------------------------------------
-- | A @Pattern@ is two Unicode characters next to one another in a password.
type Pattern = (Char, Char)

--------------------------------------------------------------------------------
-- | Direction of movement for adjacent characters.
data Direction = N | NE | E | SE | S | SW | W | NW
  deriving (forall x. Rep Direction x -> Direction
forall x. Direction -> Rep Direction x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Direction x -> Direction
$cfrom :: forall x. Direction -> Rep Direction x
Generic, Get Direction
[Direction] -> Put
Direction -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Direction] -> Put
$cputList :: [Direction] -> Put
get :: Get Direction
$cget :: Get Direction
put :: Direction -> Put
$cput :: Direction -> Put
Binary, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, Direction -> Direction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Eq Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmax :: Direction -> Direction -> Direction
>= :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c< :: Direction -> Direction -> Bool
compare :: Direction -> Direction -> Ordering
$ccompare :: Direction -> Direction -> Ordering
Ord, Int -> Direction
Direction -> Int
Direction -> [Direction]
Direction -> Direction
Direction -> Direction -> [Direction]
Direction -> Direction -> Direction -> [Direction]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
$cenumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
enumFromTo :: Direction -> Direction -> [Direction]
$cenumFromTo :: Direction -> Direction -> [Direction]
enumFromThen :: Direction -> Direction -> [Direction]
$cenumFromThen :: Direction -> Direction -> [Direction]
enumFrom :: Direction -> [Direction]
$cenumFrom :: Direction -> [Direction]
fromEnum :: Direction -> Int
$cfromEnum :: Direction -> Int
toEnum :: Int -> Direction
$ctoEnum :: Int -> Direction
pred :: Direction -> Direction
$cpred :: Direction -> Direction
succ :: Direction -> Direction
$csucc :: Direction -> Direction
Enum, Direction
forall a. a -> a -> Bounded a
maxBound :: Direction
$cmaxBound :: Direction
minBound :: Direction
$cminBound :: Direction
Bounded)

--------------------------------------------------------------------------------
-- | Movement between characters.
data Move = Move Direction | Stay
  deriving (forall x. Rep Move x -> Move
forall x. Move -> Rep Move x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Move x -> Move
$cfrom :: forall x. Move -> Rep Move x
Generic, Get Move
[Move] -> Put
Move -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Move] -> Put
$cputList :: [Move] -> Put
get :: Get Move
$cget :: Get Move
put :: Move -> Put
$cput :: Move -> Put
Binary, Int -> Move -> ShowS
[Move] -> ShowS
Move -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Move] -> ShowS
$cshowList :: [Move] -> ShowS
show :: Move -> String
$cshow :: Move -> String
showsPrec :: Int -> Move -> ShowS
$cshowsPrec :: Int -> Move -> ShowS
Show, Move -> Move -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Move -> Move -> Bool
$c/= :: Move -> Move -> Bool
== :: Move -> Move -> Bool
$c== :: Move -> Move -> Bool
Eq)

--------------------------------------------------------------------------------
-- | Keyboard layers.
data Layer = Primary | Secondary
  deriving (forall x. Rep Layer x -> Layer
forall x. Layer -> Rep Layer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Layer x -> Layer
$cfrom :: forall x. Layer -> Rep Layer x
Generic, Get Layer
[Layer] -> Put
Layer -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Layer] -> Put
$cputList :: [Layer] -> Put
get :: Get Layer
$cget :: Get Layer
put :: Layer -> Put
$cput :: Layer -> Put
Binary, Int -> Layer -> ShowS
[Layer] -> ShowS
Layer -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layer] -> ShowS
$cshowList :: [Layer] -> ShowS
show :: Layer -> String
$cshow :: Layer -> String
showsPrec :: Int -> Layer -> ShowS
$cshowsPrec :: Int -> Layer -> ShowS
Show, Layer -> Layer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Layer -> Layer -> Bool
$c/= :: Layer -> Layer -> Bool
== :: Layer -> Layer -> Bool
$c== :: Layer -> Layer -> Bool
Eq, Eq Layer
Layer -> Layer -> Bool
Layer -> Layer -> Ordering
Layer -> Layer -> Layer
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Layer -> Layer -> Layer
$cmin :: Layer -> Layer -> Layer
max :: Layer -> Layer -> Layer
$cmax :: Layer -> Layer -> Layer
>= :: Layer -> Layer -> Bool
$c>= :: Layer -> Layer -> Bool
> :: Layer -> Layer -> Bool
$c> :: Layer -> Layer -> Bool
<= :: Layer -> Layer -> Bool
$c<= :: Layer -> Layer -> Bool
< :: Layer -> Layer -> Bool
$c< :: Layer -> Layer -> Bool
compare :: Layer -> Layer -> Ordering
$ccompare :: Layer -> Layer -> Ordering
Ord, Int -> Layer
Layer -> Int
Layer -> [Layer]
Layer -> Layer
Layer -> Layer -> [Layer]
Layer -> Layer -> Layer -> [Layer]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Layer -> Layer -> Layer -> [Layer]
$cenumFromThenTo :: Layer -> Layer -> Layer -> [Layer]
enumFromTo :: Layer -> Layer -> [Layer]
$cenumFromTo :: Layer -> Layer -> [Layer]
enumFromThen :: Layer -> Layer -> [Layer]
$cenumFromThen :: Layer -> Layer -> [Layer]
enumFrom :: Layer -> [Layer]
$cenumFrom :: Layer -> [Layer]
fromEnum :: Layer -> Int
$cfromEnum :: Layer -> Int
toEnum :: Int -> Layer
$ctoEnum :: Int -> Layer
pred :: Layer -> Layer
$cpred :: Layer -> Layer
succ :: Layer -> Layer
$csucc :: Layer -> Layer
Enum, Layer
forall a. a -> a -> Bounded a
maxBound :: Layer
$cmaxBound :: Layer
minBound :: Layer
$cminBound :: Layer
Bounded)

--------------------------------------------------------------------------------
-- | Information about how two characters are related to one another.
data Adjacency = Adjacency
  { Adjacency -> Move
_movement :: Move
    -- ^ The direction moving from the first to second character.

  , Adjacency -> Layer
_firstLayer :: Layer
    -- ^ The layer that the first character is on.

  , Adjacency -> Layer
_secondLayer :: Layer
    -- ^ The layer that the second character is on.
  }
  deriving (forall x. Rep Adjacency x -> Adjacency
forall x. Adjacency -> Rep Adjacency x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Adjacency x -> Adjacency
$cfrom :: forall x. Adjacency -> Rep Adjacency x
Generic, Get Adjacency
[Adjacency] -> Put
Adjacency -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Adjacency] -> Put
$cputList :: [Adjacency] -> Put
get :: Get Adjacency
$cget :: Get Adjacency
put :: Adjacency -> Put
$cput :: Adjacency -> Put
Binary, Int -> Adjacency -> ShowS
[Adjacency] -> ShowS
Adjacency -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Adjacency] -> ShowS
$cshowList :: [Adjacency] -> ShowS
show :: Adjacency -> String
$cshow :: Adjacency -> String
showsPrec :: Int -> Adjacency -> ShowS
$cshowsPrec :: Int -> Adjacency -> ShowS
Show)

makeLenses ''Adjacency

--------------------------------------------------------------------------------
-- | An adjacency graph (usually representing a single keyboard).
data AdjacencyTable = AdjacencyTable
  { AdjacencyTable -> Int
_totalChars :: Int
    -- ^ Total number of characters in the graph (total keys on the
    -- keyboard including all layers).

  , AdjacencyTable -> Int
_averageNeighbors :: Int
    -- ^ Average number of neighbors in the graph.

  , AdjacencyTable -> Map Pattern Adjacency
_patterns :: Map Pattern Adjacency
    -- ^ Dictionary for looking up patterns.

  } deriving (forall x. Rep AdjacencyTable x -> AdjacencyTable
forall x. AdjacencyTable -> Rep AdjacencyTable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AdjacencyTable x -> AdjacencyTable
$cfrom :: forall x. AdjacencyTable -> Rep AdjacencyTable x
Generic, Get AdjacencyTable
[AdjacencyTable] -> Put
AdjacencyTable -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [AdjacencyTable] -> Put
$cputList :: [AdjacencyTable] -> Put
get :: Get AdjacencyTable
$cget :: Get AdjacencyTable
put :: AdjacencyTable -> Put
$cput :: AdjacencyTable -> Put
Binary, Int -> AdjacencyTable -> ShowS
[AdjacencyTable] -> ShowS
AdjacencyTable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AdjacencyTable] -> ShowS
$cshowList :: [AdjacencyTable] -> ShowS
show :: AdjacencyTable -> String
$cshow :: AdjacencyTable -> String
showsPrec :: Int -> AdjacencyTable -> ShowS
$cshowsPrec :: Int -> AdjacencyTable -> ShowS
Show)

makeLenses ''AdjacencyTable

--------------------------------------------------------------------------------
-- | Find a pattern if it exists.  If all characters in the given
-- 'Text' form a pattern in the given 'Graph' then a list of matches
-- will be returned.
findSequence :: Text -> AdjacencyTable -> Maybe (NonEmpty Adjacency)
findSequence :: Text -> AdjacencyTable -> Maybe (NonEmpty Adjacency)
findSequence Text
t AdjacencyTable{Int
Map Pattern Adjacency
_patterns :: Map Pattern Adjacency
_averageNeighbors :: Int
_totalChars :: Int
_patterns :: AdjacencyTable -> Map Pattern Adjacency
_averageNeighbors :: AdjacencyTable -> Int
_totalChars :: AdjacencyTable -> Int
..} =
  let chars :: String
chars = Text -> String
Text.unpack Text
t
      ms :: Maybe [Adjacency]
ms = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Pattern Adjacency
_patterns) (forall a b. [a] -> [b] -> [(a, b)]
zip String
chars (forall a. Int -> [a] -> [a]
drop Int
1 String
chars))
  in forall a. [a] -> NonEmpty a
NonEmpty.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Adjacency]
ms

--------------------------------------------------------------------------------
-- | Scoring information for adjacent characters.
data AdjacencyScore = AdjacencyScore
  { AdjacencyScore -> Int
_patternLength :: Int
    -- ^ Number of characters in the pattern.

  , AdjacencyScore -> Int
_totalTurns :: Int
    -- ^ Total number of turns needed.

  , AdjacencyScore -> Int
_primaryLayer :: Int
    -- ^ Characters that are on the primary layer.

  , AdjacencyScore -> Int
_secondaryLayer :: Int
    -- ^ Characters that are on a secondary layer.

  , AdjacencyScore -> Move
_lastMovement :: Move
    -- ^ The direction on the last character.

  } deriving (Int -> AdjacencyScore -> ShowS
[AdjacencyScore] -> ShowS
AdjacencyScore -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AdjacencyScore] -> ShowS
$cshowList :: [AdjacencyScore] -> ShowS
show :: AdjacencyScore -> String
$cshow :: AdjacencyScore -> String
showsPrec :: Int -> AdjacencyScore -> ShowS
$cshowsPrec :: Int -> AdjacencyScore -> ShowS
Show, AdjacencyScore -> AdjacencyScore -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AdjacencyScore -> AdjacencyScore -> Bool
$c/= :: AdjacencyScore -> AdjacencyScore -> Bool
== :: AdjacencyScore -> AdjacencyScore -> Bool
$c== :: AdjacencyScore -> AdjacencyScore -> Bool
Eq)

makeLenses ''AdjacencyScore

--------------------------------------------------------------------------------
instance Semigroup AdjacencyScore where
  <> :: AdjacencyScore -> AdjacencyScore -> AdjacencyScore
(<>) (AdjacencyScore Int
l Int
t Int
p Int
s Move
m) (AdjacencyScore Int
l' Int
t' Int
p' Int
s' Move
_) =
    Int -> Int -> Int -> Int -> Move -> AdjacencyScore
AdjacencyScore (Int
lforall a. Num a => a -> a -> a
+Int
l') (Int
tforall a. Num a => a -> a -> a
+Int
t') (Int
pforall a. Num a => a -> a -> a
+Int
p') (Int
sforall a. Num a => a -> a -> a
+Int
s') Move
m

--------------------------------------------------------------------------------
instance Monoid AdjacencyScore where
  mempty :: AdjacencyScore
mempty = Int -> Int -> Int -> Int -> Move -> AdjacencyScore
AdjacencyScore Int
0 Int
0 Int
0 Int
0 Move
Stay

--------------------------------------------------------------------------------
-- | Calculate the score for two adjacent characters.
scoreSequence :: AdjacencyScore -> Adjacency -> AdjacencyScore
scoreSequence :: AdjacencyScore -> Adjacency -> AdjacencyScore
scoreSequence AdjacencyScore
s Adjacency
a =
  AdjacencyScore
s forall a b. a -> (a -> b) -> b
& AdjacencyScore -> AdjacencyScore
turns
    forall a b. a -> (a -> b) -> b
& AdjacencyScore -> AdjacencyScore
layers
    forall a b. a -> (a -> b) -> b
& Lens' AdjacencyScore Int
patternLength forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ (if (AdjacencyScore
s forall s a. s -> Getting a s a -> a
^. Lens' AdjacencyScore Int
patternLength) forall a. Eq a => a -> a -> Bool
== Int
0 then Int
2 else Int
1)
    forall a b. a -> (a -> b) -> b
& Lens' AdjacencyScore Move
lastMovement  forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Adjacency
a forall s a. s -> Getting a s a -> a
^. Lens' Adjacency Move
movement)

  where
    turns :: AdjacencyScore -> AdjacencyScore
    turns :: AdjacencyScore -> AdjacencyScore
turns = if (Adjacency
a forall s a. s -> Getting a s a -> a
^. Lens' Adjacency Move
movement) forall a. Eq a => a -> a -> Bool
/= (AdjacencyScore
s forall s a. s -> Getting a s a -> a
^. Lens' AdjacencyScore Move
lastMovement)
              then Lens' AdjacencyScore Int
totalTurns forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1
              else forall a. a -> a
id

    -- Usually we focus on the layer of the second character but when
    -- we are looking at the start of the pattern we need to consider
    -- both characters.
    layers :: AdjacencyScore -> AdjacencyScore
    layers :: AdjacencyScore -> AdjacencyScore
layers = if (AdjacencyScore
s forall s a. s -> Getting a s a -> a
^. Lens' AdjacencyScore Int
patternLength) forall a. Eq a => a -> a -> Bool
== Int
0
               then Layer -> AdjacencyScore -> AdjacencyScore
layer (Adjacency
a forall s a. s -> Getting a s a -> a
^. Lens' Adjacency Layer
firstLayer) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layer -> AdjacencyScore -> AdjacencyScore
layer (Adjacency
a forall s a. s -> Getting a s a -> a
^. Lens' Adjacency Layer
secondLayer)
               else Layer -> AdjacencyScore -> AdjacencyScore
layer (Adjacency
a forall s a. s -> Getting a s a -> a
^. Lens' Adjacency Layer
secondLayer)

    layer :: Layer -> AdjacencyScore -> AdjacencyScore
    layer :: Layer -> AdjacencyScore -> AdjacencyScore
layer Layer
Primary   = Lens' AdjacencyScore Int
primaryLayer   forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1
    layer Layer
Secondary = Lens' AdjacencyScore Int
secondaryLayer forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1