Adjacency.hs

{-# LANGUAGE OverloadedStrings #-}

{-|

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 Zxcvbn.Adjacency
  ( test
  ) where

--------------------------------------------------------------------------------
import Control.Lens
import Data.Foldable (foldl')
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Test.Tasty
import Test.Tasty.HUnit

--------------------------------------------------------------------------------
import Text.Password.Strength.Internal

--------------------------------------------------------------------------------
simpleGraph :: AdjacencyTable
simpleGraph =  AdjacencyTable
    { _totalChars = 5
    , _averageNeighbors = 3
    , _patterns = makeDict
    }
  where
    makeDict :: Map Pattern Adjacency
    makeDict = Map.fromList [ (('a', 's'), Adjacency (Move E)  Primary   Primary)
                            , (('s', 'E'), Adjacency (Move NE) Primary   Secondary)
                            , (('e', 'w'), Adjacency (Move W)  Primary   Primary)
                            , (('E', 'w'), Adjacency (Move W)  Secondary Primary)
                            , (('w', 'a'), Adjacency (Move SW) Primary   Primary)
                            ]

--------------------------------------------------------------------------------
scoreQwerty :: Text -> Maybe Integer
scoreQwerty password =
  keyboardEstimate <$> keyboardPattern (en_US ^. keyboardGraphs.to head)
                         (Token password (Text.toLower password) 0 5)

--------------------------------------------------------------------------------
test :: TestTree
test = testGroup "Adjacency"
  [ testCase "asE" $ adj "asE" @?= Just (AdjacencyScore 3 2 2 1 (Move NE))
  , testCase "sEw" $ adj "sEw" @?= Just (AdjacencyScore 3 2 2 1 (Move W))
  , testCase "ewa" $ adj "ewa" @?= Just (AdjacencyScore 3 2 3 0 (Move SW))
  , testCase "aSE" $ adj "aSE" @?= Nothing

  -- Testing scoring:
  , testCase "asdf"   $ scoreQwerty "asdf"   @?= Just 1128   -- Python: 1296
  , testCase "asdftG" $ scoreQwerty "asdftG" @?= Just 205860 -- Python: 1219890
  ]

  where
    adj :: Text -> Maybe AdjacencyScore
    adj p = foldl' scoreSequence mempty <$> findSequence p simpleGraph