{-# 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 forall a b. a -> (a -> b) -> b
& forall c. HasConfig c => Lens' c [Dictionary]
passwordLists        forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ (Config
y forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c [Dictionary]
passwordLists))
        forall a b. a -> (a -> b) -> b
& forall c. HasConfig c => Lens' c [Dictionary]
wordFrequencyLists   forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ (Config
y forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c [Dictionary]
wordFrequencyLists))
        forall a b. a -> (a -> b) -> b
& forall c. HasConfig c => Lens' c [Dictionary]
customFrequencyLists forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ (Config
y forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c [Dictionary]
customFrequencyLists))
        forall a b. a -> (a -> b) -> b
& forall c. HasConfig c => Lens' c [AdjacencyTable]
keyboardGraphs       forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ (Config
y forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c [AdjacencyTable]
keyboardGraphs))
        forall a b. a -> (a -> b) -> b
& forall c. HasConfig c => Lens' c (Char -> Bool)
obviousSequenceStart 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 forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c (Char -> Bool)
obviousSequenceStart) Char
c
             Bool -> Bool -> Bool
|| (Config
y forall s a. s -> Getting a s a -> a
^. 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 [] [] [] [] (forall a b. a -> b -> a
const Bool
False)

--------------------------------------------------------------------------------
-- | Default configuration for US English.
en_US :: Config
en_US :: Config
en_US = 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 forall a. Eq a => a -> a -> Bool
== Char
'a' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'A' Bool -> Bool -> Bool
||
      Char
c forall a. Eq a => a -> a -> Bool
== Char
'z' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'Z' Bool -> Bool -> Bool
||
      Char
c forall a. Eq a => a -> a -> Bool
== Char
'0' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'1' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'9'

--------------------------------------------------------------------------------
-- | Access all configured dictionaries.
dictionaries :: Config -> [Dictionary]
dictionaries :: Config -> [Dictionary]
dictionaries Config
c = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [ Config
c forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c [Dictionary]
passwordLists
                      , Config
c forall s a. s -> Getting a s a -> a
^. forall c. HasConfig c => Lens' c [Dictionary]
wordFrequencyLists
                      , Config
c forall s a. s -> Getting a s a -> a
^. 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 = forall a b. (Int -> a -> b -> b) -> b -> Vector a -> b
Vector.ifoldr (\Int
i Text
x -> forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
x (Int
iforall a. Num a => a -> a -> a
+Int
1)) forall k v. HashMap k v
HashMap.empty

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