{-# 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.Config (
  -- * Configuration
  Config,
  HasConfig(..),
  Dictionary,
  en_US,
  dictionaries,
  addCustomFrequencyList
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((&), (^.), (.~), (%~))
import Control.Lens.TH (makeClassy)
import Control.Monad (join)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as Vector

--------------------------------------------------------------------------------
-- Project Imports:
import qualified Text.Password.Strength.Generated.Adjacency as Adjc
import qualified Text.Password.Strength.Generated.Frequency as Freq
import Text.Password.Strength.Internal.Adjacency (AdjacencyTable)

--------------------------------------------------------------------------------
-- | Type alias for a frequency database.
type Dictionary = HashMap Text Int

--------------------------------------------------------------------------------
-- | A type to control which dictionaries, keyboard layouts, etc. will
-- be used when estimating guesses.
data Config = Config
  { Config -> [Dictionary]
_passwordLists :: [Dictionary]
  , Config -> [Dictionary]
_wordFrequencyLists :: [Dictionary]
  , Config -> [Dictionary]
_customFrequencyLists :: [Dictionary]
  , Config -> [AdjacencyTable]
_keyboardGraphs :: [AdjacencyTable]
  , Config -> Char -> Bool
_obviousSequenceStart :: Char -> Bool
  }

makeClassy ''Config

--------------------------------------------------------------------------------
instance Semigroup Config where
  <> :: Config -> Config -> Config
(<>) Config
x Config
y =
      Config
x Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& ([Dictionary] -> Identity [Dictionary])
-> Config -> Identity Config
forall c. HasConfig c => Lens' c [Dictionary]
passwordLists        (([Dictionary] -> Identity [Dictionary])
 -> Config -> Identity Config)
-> ([Dictionary] -> [Dictionary]) -> Config -> Config
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Dictionary] -> [Dictionary] -> [Dictionary]
forall a. [a] -> [a] -> [a]
++ (Config
y Config -> Getting [Dictionary] Config [Dictionary] -> [Dictionary]
forall s a. s -> Getting a s a -> a
^. Getting [Dictionary] Config [Dictionary]
forall c. HasConfig c => Lens' c [Dictionary]
passwordLists))
        Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& ([Dictionary] -> Identity [Dictionary])
-> Config -> Identity Config
forall c. HasConfig c => Lens' c [Dictionary]
wordFrequencyLists   (([Dictionary] -> Identity [Dictionary])
 -> Config -> Identity Config)
-> ([Dictionary] -> [Dictionary]) -> Config -> Config
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Dictionary] -> [Dictionary] -> [Dictionary]
forall a. [a] -> [a] -> [a]
++ (Config
y Config -> Getting [Dictionary] Config [Dictionary] -> [Dictionary]
forall s a. s -> Getting a s a -> a
^. Getting [Dictionary] Config [Dictionary]
forall c. HasConfig c => Lens' c [Dictionary]
wordFrequencyLists))
        Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& ([Dictionary] -> Identity [Dictionary])
-> Config -> Identity Config
forall c. HasConfig c => Lens' c [Dictionary]
customFrequencyLists (([Dictionary] -> Identity [Dictionary])
 -> Config -> Identity Config)
-> ([Dictionary] -> [Dictionary]) -> Config -> Config
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Dictionary] -> [Dictionary] -> [Dictionary]
forall a. [a] -> [a] -> [a]
++ (Config
y Config -> Getting [Dictionary] Config [Dictionary] -> [Dictionary]
forall s a. s -> Getting a s a -> a
^. Getting [Dictionary] Config [Dictionary]
forall c. HasConfig c => Lens' c [Dictionary]
customFrequencyLists))
        Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& ([AdjacencyTable] -> Identity [AdjacencyTable])
-> Config -> Identity Config
forall c. HasConfig c => Lens' c [AdjacencyTable]
keyboardGraphs       (([AdjacencyTable] -> Identity [AdjacencyTable])
 -> Config -> Identity Config)
-> ([AdjacencyTable] -> [AdjacencyTable]) -> Config -> Config
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([AdjacencyTable] -> [AdjacencyTable] -> [AdjacencyTable]
forall a. [a] -> [a] -> [a]
++ (Config
y Config
-> Getting [AdjacencyTable] Config [AdjacencyTable]
-> [AdjacencyTable]
forall s a. s -> Getting a s a -> a
^. Getting [AdjacencyTable] Config [AdjacencyTable]
forall c. HasConfig c => Lens' c [AdjacencyTable]
keyboardGraphs))
        Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& ((Char -> Bool) -> Identity (Char -> Bool))
-> Config -> Identity Config
forall c. HasConfig c => Lens' c (Char -> Bool)
obviousSequenceStart (((Char -> Bool) -> Identity (Char -> Bool))
 -> Config -> Identity Config)
-> (Char -> Bool) -> Config -> Config
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Char -> Bool
oss
      where
        -- Laws:
        --
        -- >>> x <> y
        --
        -- * Left identity:  (\c -> const False c || y c) == y c
        -- * Right identity: (\c -> x c || const False c) == x c
        --
        -- * Associativity:
        --
        --   (\c -> (x c || y c) || z c) == (\c -> (x c || (y c || z c)))
        oss :: Char -> Bool
        oss :: Char -> Bool
oss Char
c = (Config
x Config
-> Getting (Char -> Bool) Config (Char -> Bool) -> Char -> Bool
forall s a. s -> Getting a s a -> a
^. Getting (Char -> Bool) Config (Char -> Bool)
forall c. HasConfig c => Lens' c (Char -> Bool)
obviousSequenceStart) Char
c
             Bool -> Bool -> Bool
|| (Config
y Config
-> Getting (Char -> Bool) Config (Char -> Bool) -> Char -> Bool
forall s a. s -> Getting a s a -> a
^. Getting (Char -> Bool) Config (Char -> Bool)
forall c. HasConfig c => Lens' c (Char -> Bool)
obviousSequenceStart) Char
c

--------------------------------------------------------------------------------
instance Monoid Config where
  mempty :: Config
mempty = [Dictionary]
-> [Dictionary]
-> [Dictionary]
-> [AdjacencyTable]
-> (Char -> Bool)
-> Config
Config [] [] [] [] (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
False)

--------------------------------------------------------------------------------
-- | Default configuration for US English.
en_US :: Config
en_US :: Config
en_US = Config :: [Dictionary]
-> [Dictionary]
-> [Dictionary]
-> [AdjacencyTable]
-> (Char -> Bool)
-> Config
Config{[Dictionary]
[AdjacencyTable]
Char -> Bool
forall a. [a]
_obviousSequenceStart :: Char -> Bool
_keyboardGraphs :: [AdjacencyTable]
_wordFrequencyLists :: [Dictionary]
_passwordLists :: [Dictionary]
_customFrequencyLists :: forall a. [a]
_obviousSequenceStart :: Char -> Bool
_keyboardGraphs :: [AdjacencyTable]
_customFrequencyLists :: [Dictionary]
_wordFrequencyLists :: [Dictionary]
_passwordLists :: [Dictionary]
..}
  where
    _customFrequencyLists :: [a]
_customFrequencyLists = []
    _passwordLists :: [Dictionary]
_passwordLists        = [ Dictionary
Freq.xato ]
    _wordFrequencyLists :: [Dictionary]
_wordFrequencyLists   = [ Dictionary
Freq.english_wikipedia
                            , Dictionary
Freq.female_names
                            , Dictionary
Freq.male_names
                            , Dictionary
Freq.surnames
                            , Dictionary
Freq.us_tv_and_film
                            ]
    _keyboardGraphs :: [AdjacencyTable]
_keyboardGraphs       = [ AdjacencyTable
Adjc.qwerty
                            , AdjacencyTable
Adjc.numpad
                            ]
    _obviousSequenceStart :: Char -> Bool
_obviousSequenceStart Char
c =
      Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'a' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'A' Bool -> Bool -> Bool
||
      Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Z' Bool -> Bool -> Bool
||
      Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'1' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'9'

--------------------------------------------------------------------------------
-- | Access all configured dictionaries.
dictionaries :: Config -> [Dictionary]
dictionaries :: Config -> [Dictionary]
dictionaries Config
c = [[Dictionary]] -> [Dictionary]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [ Config
c Config -> Getting [Dictionary] Config [Dictionary] -> [Dictionary]
forall s a. s -> Getting a s a -> a
^. Getting [Dictionary] Config [Dictionary]
forall c. HasConfig c => Lens' c [Dictionary]
passwordLists
                      , Config
c Config -> Getting [Dictionary] Config [Dictionary] -> [Dictionary]
forall s a. s -> Getting a s a -> a
^. Getting [Dictionary] Config [Dictionary]
forall c. HasConfig c => Lens' c [Dictionary]
wordFrequencyLists
                      , Config
c Config -> Getting [Dictionary] Config [Dictionary] -> [Dictionary]
forall s a. s -> Getting a s a -> a
^. Getting [Dictionary] Config [Dictionary]
forall c. HasConfig c => Lens' c [Dictionary]
customFrequencyLists
                      ]

--------------------------------------------------------------------------------
-- | Add a custom list of words for frequency lookup.  The words
-- should be ordered from most frequent to least frequent.
addCustomFrequencyList :: Vector Text -> Config -> Config
addCustomFrequencyList :: Vector Text -> Config -> Config
addCustomFrequencyList Vector Text
v = Dictionary -> Config -> Config
addDict (Vector Text -> Dictionary
mkDict Vector Text
v)
  where
    mkDict :: Vector Text -> Dictionary
    mkDict :: Vector Text -> Dictionary
mkDict = (Int -> Text -> Dictionary -> Dictionary)
-> Dictionary -> Vector Text -> Dictionary
forall a b. (Int -> a -> b -> b) -> b -> Vector a -> b
Vector.ifoldr (\Int
i Text
x -> Text -> Int -> Dictionary -> Dictionary
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
x (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Dictionary
forall k v. HashMap k v
HashMap.empty

    addDict :: Dictionary -> Config -> Config
    addDict :: Dictionary -> Config -> Config
addDict Dictionary
d = ([Dictionary] -> Identity [Dictionary])
-> Config -> Identity Config
forall c. HasConfig c => Lens' c [Dictionary]
customFrequencyLists (([Dictionary] -> Identity [Dictionary])
 -> Config -> Identity Config)
-> ([Dictionary] -> [Dictionary]) -> Config -> Config
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Dictionary
dDictionary -> [Dictionary] -> [Dictionary]
forall a. a -> [a] -> [a]
:)