{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# 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.L33t (
  -- * L33t Speak Substitution
  L33t,
  l33t,
  l33tText,
  l33tSub,
  l33tUnsub,
  l33t2Eng
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((^.))
import Control.Lens.TH (makeLenses)
import Data.Text (Text)
import qualified Data.Text as Text

--------------------------------------------------------------------------------
-- Project Imports:
import Text.Password.Strength.Internal.Token

--------------------------------------------------------------------------------
-- | Track a translated l33t speak token.
data L33t = L33t
  { L33t -> Text
_l33tText :: Text
    -- ^ The translated (un-l33ted) text.

  , L33t -> Int
_l33tSub :: Int
    -- ^ Number of substituted l33t characters.

  , L33t -> Int
_l33tUnsub :: Int
    -- ^ Number of characters in the token that were not substituted
    -- but could have been.

  } deriving Int -> L33t -> ShowS
[L33t] -> ShowS
L33t -> String
(Int -> L33t -> ShowS)
-> (L33t -> String) -> ([L33t] -> ShowS) -> Show L33t
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [L33t] -> ShowS
$cshowList :: [L33t] -> ShowS
show :: L33t -> String
$cshow :: L33t -> String
showsPrec :: Int -> L33t -> ShowS
$cshowsPrec :: Int -> L33t -> ShowS
Show

makeLenses ''L33t

--------------------------------------------------------------------------------
-- | Translate a token from l33t, counting l33t characters.
l33t :: Token -> [L33t]
l33t :: Token -> [L33t]
l33t Token
token
  | Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
Text.any ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
l33tCount) Text
chars) = []
  | Bool
otherwise = (L33t -> Bool) -> [L33t] -> [L33t]
forall a. (a -> Bool) -> [a] -> [a]
filter L33t -> Bool
hasSubs (((Token, Text) -> L33t) -> [(Token, Text)] -> [L33t]
forall a b. (a -> b) -> [a] -> [b]
map (Token, Text) -> L33t
count [(Token, Text)]
trans)
  where
    hasSubs :: L33t -> Bool
    hasSubs :: L33t -> Bool
hasSubs L33t{Int
Text
_l33tUnsub :: Int
_l33tSub :: Int
_l33tText :: Text
_l33tUnsub :: L33t -> Int
_l33tSub :: L33t -> Int
_l33tText :: L33t -> Text
..} = Int
_l33tSub Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Int
_l33tUnsub Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    chars :: Text
    chars :: Text
chars = Token
token Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenLower

    trans :: [(Token, Text)]
    trans :: [(Token, Text)]
trans  = case (Char -> String) -> Text -> [Text]
translateMap Char -> String
l33t2Eng Text
chars of
               [Text
x] | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
chars -> []
                   | Bool
otherwise  -> [(Token
token, Text
x)]
               [Text]
xs               -> (Text -> (Token, Text)) -> [Text] -> [(Token, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Token
token,) [Text]
xs

    count :: (Token, Text) -> L33t
    count :: (Token, Text) -> L33t
count (Token
tk, Text
text) =
      let cnt :: (Int, Int) -> Char -> (Int, Int)
cnt (Int
x, Int
y) Char
c = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
l33tCount Char
c, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
engCount Char
c)
          (Int
s, Int
u) = ((Int, Int) -> Char -> (Int, Int))
-> (Int, Int) -> Text -> (Int, Int)
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl (Int, Int) -> Char -> (Int, Int)
cnt (Int
0, Int
0) (Token
tk Token -> Getting Text Token Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Token Text
Lens' Token Text
tokenChars)
      in Text -> Int -> Int -> L33t
L33t Text
text Int
s Int
u

--------------------------------------------------------------------------------
-- | Convert l33t characters to their English character mappings.
l33t2Eng :: Char -> String
l33t2Eng :: Char -> String
l33t2Eng Char
c =
  case Char
c of
    Char
'!' -> [Char
'i']
    Char
'$' -> [Char
's']
    Char
'%' -> [Char
'x']
    Char
'(' -> [Char
'c']
    Char
'+' -> [Char
't']
    Char
'0' -> [Char
'o']
    Char
'1' -> [Char
'i', Char
'l']
    Char
'2' -> [Char
'z']
    Char
'3' -> [Char
'e']
    Char
'4' -> [Char
'a']
    Char
'5' -> [Char
's']
    Char
'6' -> [Char
'g']
    Char
'7' -> [Char
'l', Char
't']
    Char
'8' -> [Char
'b']
    Char
'9' -> [Char
'g']
    Char
'<' -> [Char
'c']
    Char
'@' -> [Char
'a']
    Char
'[' -> [Char
'c']
    Char
'{' -> [Char
'c']
    Char
'|' -> [Char
'i', Char
'l']
    Char
_   -> []

--------------------------------------------------------------------------------
-- | Character count for English letters that can be converted to l33t.
--
-- There's a theoretically possible under estimation here since some
-- English characters can be converted into multiple l33t characters.
-- In reality, English characters tend to have one primary l33t
-- character associated with them.
--
-- An attacker may try all l33t variations for a given English
-- character, but chances are that the primary character was used so
-- we will estimate guesses based on that assumption.
engCount :: Char -> Int
engCount :: Char -> Int
engCount Char
c =
  case Char
c of
    Char
'a' -> Int
1
    Char
'b' -> Int
1
    Char
'c' -> Int
1
    Char
'e' -> Int
1
    Char
'g' -> Int
1
    Char
'i' -> Int
1
    Char
'l' -> Int
1
    Char
'o' -> Int
1
    Char
's' -> Int
1
    Char
't' -> Int
1
    Char
'x' -> Int
1
    Char
'z' -> Int
1
    Char
_   -> Int
0

--------------------------------------------------------------------------------
-- | Character count for l33t characters that can be converted to l33t.
l33tCount :: Char -> Int
l33tCount :: Char -> Int
l33tCount Char
c =
  case Char
c of
    Char
'!' -> Int
1
    Char
'$' -> Int
1
    Char
'%' -> Int
1
    Char
'(' -> Int
1
    Char
'+' -> Int
1
    Char
'0' -> Int
1
    Char
'1' -> Int
1
    Char
'2' -> Int
1
    Char
'3' -> Int
1
    Char
'4' -> Int
1
    Char
'5' -> Int
1
    Char
'6' -> Int
1
    Char
'7' -> Int
1
    Char
'8' -> Int
1
    Char
'9' -> Int
1
    Char
'<' -> Int
1
    Char
'@' -> Int
1
    Char
'[' -> Int
1
    Char
'{' -> Int
1
    Char
'|' -> Int
1
    Char
_   -> Int
0