{-# LANGUAGE RecordWildCards #-}
{-# 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.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
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 = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Token -> (Int, Int)
loc (Config -> Matches -> Guesses
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 forall s a. s -> Getting a s a -> a
^. Lens' Token Int
startIndex, Token
t forall s a. s -> Getting a s a -> a
^. Lens' Token Int
endIndex 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> ((Int, Int), Integer)
guesses 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
0forall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field2 s t a b => Lens s t a b
_2) (forall k a. Map k a -> [k]
Map.keys Map (Int, Int) Integer
es)
      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 <- forall a b. (a -> b) -> [a] -> [b]
map (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 k a. Map k a -> [k]
Map.keys Map (Int, Int) Integer
es) forall a. [a] -> [a] -> [a]
++ [Text -> Int
Text.length Text
p]
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
y forall a. Ord a => a -> a -> Bool
> Int
x)
      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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Int, Int) Integer
es) [(Int, Int)]
row
        then forall a. Maybe a
Nothing
        else 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 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' (forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
Graph.mkGraph [Node]
nodes (Map (Int, Int) Integer -> [(Int, Int, Integer)]
flatten Map (Int, Int) Integer
edges'))
  where
    exit :: Int
    exit :: Int
exit = Text -> Int
Text.length Text
password

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

    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 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` 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 -> [(Int, Int, Integer)]
flatten = forall a b. (a -> b) -> [a] -> [b]
map (\((Int
x, Int
y), Integer
z) -> (Int
x, Int
y, Integer
z)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
worstCase 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 = forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
xs (forall a. Int -> [a] -> [a]
drop Int
1 [Int]
xs)

    scores :: [(Int, Int)] -> Maybe [Integer]
    scores :: [(Int, Int)] -> Maybe [Integer]
scores = 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 (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
..} = forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Int -> Int -> gr a b -> Maybe [Int]
sp Int
0 Int
exitNode Gr () Integer
scoreGraph