{-# LANGUAGE RecordWildCards #-}

{-|

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.Search (
  -- * Searching for the Weakest Path Through a Password
  Graph(..),
  Node,
  Edge,
  edges,
  bfEdges,
  graph,
  score,
  shortestPath
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((^.), _1, _2)
import Control.Monad (guard)
import qualified Data.Graph.Inductive.Graph as Graph
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.SP (sp)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe, mapMaybe)
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.Estimate
import Text.Password.Strength.Internal.Match
import Text.Password.Strength.Internal.Math
import Text.Password.Strength.Internal.Token

--------------------------------------------------------------------------------
-- | A node in a guessing graph.
type Node = Graph.LNode ()

--------------------------------------------------------------------------------
-- | An edge is a guessing graph.
type Edge = Graph.LEdge Integer

--------------------------------------------------------------------------------
-- | A password and estimated guesses represented as a graph.
data Graph = Graph
  { Graph -> Int
exitNode   :: Int
  , Graph -> Map (Int, Int) Integer
graphEdges :: Map (Int, Int) Integer
  , Graph -> Gr () Integer
scoreGraph :: Gr () Integer
  } deriving Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Int -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Graph] -> ShowS
$cshowList :: [Graph] -> ShowS
show :: Graph -> String
$cshow :: Graph -> String
showsPrec :: Int -> Graph -> ShowS
$cshowsPrec :: Int -> Graph -> ShowS
Show

--------------------------------------------------------------------------------
-- | Given a password and a user word list, produce graph edges that
-- connect the characters of the password.
edges :: Config -> Day -> Text -> Map (Int, Int) Integer
edges :: Config -> Day -> Text -> Map (Int, Int) Integer
edges Config
c Day
d Text
p = (Token -> (Int, Int))
-> Map Token Integer -> Map (Int, Int) Integer
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Token -> (Int, Int)
loc (Config -> Matches -> Map Token Integer
estimateAll Config
c (Config -> Day -> Text -> Matches
matches Config
c Day
d Text
p))
  where
    -- Convert a token into a location (Node).
    loc :: Token -> (Int, Int)
    loc :: Token -> (Int, Int)
loc Token
t = (Token
t Token -> Getting Int Token Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Token Int
Lens' Token Int
startIndex, Token
t Token -> Getting Int Token Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Token Int
Lens' Token Int
endIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

--------------------------------------------------------------------------------
-- | Brute force edges.  In other words, the edges required to ensure
-- there's a path in the graph from the start node to the end node.
bfEdges :: Text -> Map (Int, Int) Integer -> [((Int, Int), Integer)]
bfEdges :: Text -> Map (Int, Int) Integer -> [((Int, Int), Integer)]
bfEdges Text
p Map (Int, Int) Integer
es = ([(Int, Int)] -> Maybe ((Int, Int), Integer))
-> [[(Int, Int)]] -> [((Int, Int), Integer)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((Int, Int) -> ((Int, Int), Integer))
-> Maybe (Int, Int) -> Maybe ((Int, Int), Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> ((Int, Int), Integer)
guesses (Maybe (Int, Int) -> Maybe ((Int, Int), Integer))
-> ([(Int, Int)] -> Maybe (Int, Int))
-> [(Int, Int)]
-> Maybe ((Int, Int), Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> Maybe (Int, Int)
check) [[(Int, Int)]]
rows

  where
    -- A list of rows, where a row is a pairing of a starting point
    -- and all possible ending points.
    rows :: [[(Int, Int)]]
    rows :: [[(Int, Int)]]
rows = do
      Int
x  <- Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Getting Int (Int, Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, Int) Int
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Map (Int, Int) Integer -> [(Int, Int)]
forall k a. Map k a -> [k]
Map.keys Map (Int, Int) Integer
es)
      [(Int, Int)] -> [[(Int, Int)]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> [(Int, Int)]
pair Int
x)

    -- Pair a starting point with an ending point.
    pair :: Int -> [(Int, Int)]
    pair :: Int -> [(Int, Int)]
pair Int
x = do
      Int
y <- ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Getting Int (Int, Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, Int) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1) (Map (Int, Int) Integer -> [(Int, Int)]
forall k a. Map k a -> [k]
Map.keys Map (Int, Int) Integer
es) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Text -> Int
Text.length Text
p]
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
x)
      (Int, Int) -> [(Int, Int)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
x, Int
y)

    -- Check a row to see if an edge needs to be created.  If so, the
    -- required edge is returned.
    check :: [(Int, Int)] -> Maybe (Int, Int)
    check :: [(Int, Int)] -> Maybe (Int, Int)
check [(Int, Int)]
row =
      if ((Int, Int) -> Bool) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int, Int) -> Map (Int, Int) Integer -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Int, Int) Integer
es) [(Int, Int)]
row
        then Maybe (Int, Int)
forall a. Maybe a
Nothing
        else [(Int, Int)] -> Maybe (Int, Int)
forall a. [a] -> Maybe a
listToMaybe [(Int, Int)]
row

    guesses :: (Int, Int) -> ((Int, Int), Integer)
    guesses :: (Int, Int) -> ((Int, Int), Integer)
guesses (Int
x, Int
y) = ((Int
x, Int
y), Int -> Integer
bruteForce (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x))

--------------------------------------------------------------------------------
-- | Generate a guessing graph from the given password and user word
-- list.  In the guessing graph the nodes are the characters in the
-- password and the edges are the estimated guesses.
graph :: Config -> Day -> Text -> Graph
graph :: Config -> Day -> Text -> Graph
graph Config
cfg Day
day Text
password =
    Int -> Map (Int, Int) Integer -> Gr () Integer -> Graph
Graph Int
exit Map (Int, Int) Integer
edges' ([LNode ()] -> [LEdge Integer] -> Gr () Integer
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
Graph.mkGraph [LNode ()]
nodes (Map (Int, Int) Integer -> [LEdge Integer]
flatten Map (Int, Int) Integer
edges'))
  where
    exit :: Int
    exit :: Int
exit = Text -> Int
Text.length Text
password

    nodes :: [Node]
    nodes :: [LNode ()]
nodes = [Int] -> [()] -> [LNode ()]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
exit] (() -> [()]
forall a. a -> [a]
repeat ())

    edges' :: Map (Int, Int) Integer
    edges' :: Map (Int, Int) Integer
edges' =
      let es :: Map (Int, Int) Integer
es = Config -> Day -> Text -> Map (Int, Int) Integer
edges Config
cfg Day
day Text
password
      in Map (Int, Int) Integer
es Map (Int, Int) Integer
-> Map (Int, Int) Integer -> Map (Int, Int) Integer
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` [((Int, Int), Integer)] -> Map (Int, Int) Integer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Text -> Map (Int, Int) Integer -> [((Int, Int), Integer)]
bfEdges Text
password Map (Int, Int) Integer
es)

    flatten :: Map (Int, Int) Integer -> [(Int, Int, Integer)]
    flatten :: Map (Int, Int) Integer -> [LEdge Integer]
flatten = (((Int, Int), Integer) -> LEdge Integer)
-> [((Int, Int), Integer)] -> [LEdge Integer]
forall a b. (a -> b) -> [a] -> [b]
map (\((Int
x, Int
y), Integer
z) -> (Int
x, Int
y, Integer
z)) ([((Int, Int), Integer)] -> [LEdge Integer])
-> (Map (Int, Int) Integer -> [((Int, Int), Integer)])
-> Map (Int, Int) Integer
-> [LEdge Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Int, Int) Integer -> [((Int, Int), Integer)]
forall k a. Map k a -> [(k, a)]
Map.assocs

--------------------------------------------------------------------------------
-- | Collapse a graph down to a single score which represents the
-- estimated number of guesses it would take to crack the password.
score :: Graph -> Integer
score :: Graph -> Integer
score g :: Graph
g@Graph{Int
Map (Int, Int) Integer
Gr () Integer
scoreGraph :: Gr () Integer
graphEdges :: Map (Int, Int) Integer
exitNode :: Int
scoreGraph :: Graph -> Gr () Integer
graphEdges :: Graph -> Map (Int, Int) Integer
exitNode :: Graph -> Int
..} =
  case Graph -> Maybe [Int]
shortestPath Graph
g of
    Maybe [Int]
Nothing   -> Integer
worstCase
    Just [Int]
path -> Integer -> ([Integer] -> Integer) -> Maybe [Integer] -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
worstCase [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([(Int, Int)] -> Maybe [Integer]
scores ([Int] -> [(Int, Int)]
nodes [Int]
path))

  where
    worstCase :: Integer
    worstCase :: Integer
worstCase = Int -> Integer
bruteForce Int
exitNode

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

    scores :: [(Int, Int)] -> Maybe [Integer]
    scores :: [(Int, Int)] -> Maybe [Integer]
scores = ((Int, Int) -> Maybe Integer) -> [(Int, Int)] -> Maybe [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int, Int) -> Map (Int, Int) Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map (Int, Int) Integer
graphEdges)

--------------------------------------------------------------------------------
-- | Calculate the shortest path through a guessing graph.  In other
-- words, the cheapest path for guessing a password.
shortestPath :: Graph -> Maybe [Int]
shortestPath :: Graph -> Maybe [Int]
shortestPath Graph{Int
Map (Int, Int) Integer
Gr () Integer
scoreGraph :: Gr () Integer
graphEdges :: Map (Int, Int) Integer
exitNode :: Int
scoreGraph :: Graph -> Gr () Integer
graphEdges :: Graph -> Map (Int, Int) Integer
exitNode :: Graph -> Int
..} = Int -> Int -> Gr () Integer -> Maybe [Int]
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Int -> Int -> gr a b -> Maybe [Int]
sp Int
0 Int
exitNode Gr () Integer
scoreGraph