{-# 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.Date (
  -- * Date Matches
  Date,
  YMD,
  isDate,
  toYMD,
  estimateDate
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((&), (^.), (+~), _1)
import Control.Lens.TH (makeLenses)
import qualified Data.Attoparsec.Text as Atto
import Data.Char (isDigit, isSpace)
import Data.Function (on)
import Data.List (sortBy)
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import qualified Data.Time.Calendar as Time

--------------------------------------------------------------------------------
-- | A date as a triple.
data Date = Date
  { Date -> Int
_year    :: Int     -- ^ A recent year.
  , Date -> Int
_month   :: Int     -- ^ 1-12.
  , Date -> Int
_day     :: Int     -- ^ 1-31.
  , Date -> Bool
_hasSep  :: Bool    -- ^ Was a separator found in the date string?
  , Date -> Integer
_refYear :: Integer -- ^ What year are we comparing to?
  } deriving Int -> Date -> ShowS
[Date] -> ShowS
Date -> String
(Int -> Date -> ShowS)
-> (Date -> String) -> ([Date] -> ShowS) -> Show Date
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Date] -> ShowS
$cshowList :: [Date] -> ShowS
show :: Date -> String
$cshow :: Date -> String
showsPrec :: Int -> Date -> ShowS
$cshowsPrec :: Int -> Date -> ShowS
Show

makeLenses ''Date

--------------------------------------------------------------------------------
-- | Components of a found date (year, month, day).
type YMD = (Int, Int, Int)

--------------------------------------------------------------------------------
-- | Helper function to construct a 'Date' record.
toDate :: Bool -> Integer -> YMD -> Date
toDate :: Bool -> Integer -> YMD -> Date
toDate Bool
s Integer
r (Int
x,Int
y,Int
z) = Int -> Int -> Int -> Bool -> Integer -> Date
Date Int
x Int
y Int
z Bool
s Integer
r

--------------------------------------------------------------------------------
-- | Extract the date components of a 'Date' record.
toYMD :: Date -> YMD
toYMD :: Date -> YMD
toYMD Date
d = (Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
year, Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
month, Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
day)

--------------------------------------------------------------------------------
-- | If the given text wholly contains a date, return it.
isDate :: Time.Day -> Text -> Maybe Date
isDate :: Day -> Text -> Maybe Date
isDate Day
ref Text
t =
  [Date] -> Maybe Date
forall a. [a] -> Maybe a
listToMaybe ([Date] -> Maybe Date) -> [Date] -> Maybe Date
forall a b. (a -> b) -> a -> b
$
    [Date] -> [Date]
order ([Date] -> [Date]) -> [Date] -> [Date]
forall a b. (a -> b) -> a -> b
$
      (Date -> Bool) -> [Date] -> [Date]
forall a. (a -> Bool) -> [a] -> [a]
filter Date -> Bool
valid ([Date] -> [Date]) -> [Date] -> [Date]
forall a b. (a -> b) -> a -> b
$
        (Date -> Date) -> [Date] -> [Date]
forall a b. (a -> b) -> [a] -> [b]
map Date -> Date
fixYear [Date]
dates
  where
    dates :: [Date]
    dates :: [Date]
dates =
      case Parser [YMD] -> Text -> Either String [YMD]
forall a. Parser a -> Text -> Either String a
Atto.parseOnly Parser [YMD]
dateAvecSep Text
t of
        Left String
_   -> Bool -> Integer -> YMD -> Date
toDate Bool
False Integer
refY (YMD -> Date) -> [YMD] -> [Date]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [YMD]
dateSansSep Text
t
        Right [YMD]
ds -> Bool -> Integer -> YMD -> Date
toDate Bool
True  Integer
refY (YMD -> Date) -> [YMD] -> [Date]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [YMD]
ds

    order :: [Date] -> [Date]
    order :: [Date] -> [Date]
order = (Date -> Date -> Ordering) -> [Date] -> [Date]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> (Date -> Integer) -> Date -> Date -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Date -> Integer
distance)

    distance :: Date -> Integer
    distance :: Date -> Integer
distance Date
d = Integer -> Integer
forall a. Num a => a -> a
abs (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
year) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
refY)

    valid :: Date -> Bool
    valid :: Date -> Bool
valid Date
date =
      let d :: Int
d = Date
date Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
day
          m :: Int
m = Date
date Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
month
          y :: Int
y = Date
date Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
year
      in    Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
12
         Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
         Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastCentury
         Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
thisCentury Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100)

    fixYear :: Date -> Date
    fixYear :: Date -> Date
fixYear Date
d | (Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
year) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
99 = Date
d
              | (Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
year) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
50 = Date
d Date -> (Date -> Date) -> Date
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Date -> Identity Date
Lens' Date Int
year ((Int -> Identity Int) -> Date -> Identity Date)
-> Int -> Date -> Date
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
lastCentury
              | Bool
otherwise        = Date
d Date -> (Date -> Date) -> Date
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Date -> Identity Date
Lens' Date Int
year ((Int -> Identity Int) -> Date -> Identity Date)
-> Int -> Date -> Date
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
thisCentury

    -- Reference year for sorting and scoring.
    refY :: Integer
    refY :: Integer
refY = Day -> (Integer, Int, Int)
Time.toGregorian Day
ref (Integer, Int, Int)
-> Getting Integer (Integer, Int, Int) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer (Integer, Int, Int) Integer
forall s t a b. Field1 s t a b => Lens s t a b
_1

    lastCentury :: Int
    lastCentury :: Int
lastCentury = Integer -> Int
forall a. Num a => Integer -> a
fromInteger ((Integer
refY Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100

    thisCentury :: Int
    thisCentury :: Int
thisCentury = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
refY Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100

--------------------------------------------------------------------------------
-- | Estimate the number of guesses for a date match.
--
-- Deviations from the zxcvbn paper:
--
--   1. The other implementations limit the year multiplier to 20 so
--      we do the same here.
--
--   2. The other implementations multiply by 4 when date separators
--      are used in the token.  We do the same.
estimateDate :: Date -> Integer
estimateDate :: Date -> Integer
estimateDate Date
d =
  let space :: Integer
space = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (Integer -> Integer
forall a. Num a => a -> a
abs (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Date
d Date -> Getting Int Date Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Date Int
Lens' Date Int
year) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Date
d Date -> Getting Integer Date Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer Date Integer
Lens' Date Integer
refYear))) Integer
20
      guesses :: Integer
guesses = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 Integer
space Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
365
  in if Date
d Date -> Getting Bool Date Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Date Bool
Lens' Date Bool
hasSep
       then Integer
guesses Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
4
       else Integer
guesses

--------------------------------------------------------------------------------
-- | Helper type for a triple of @Text -> Maybe a@ parser.
type Read3 a = (Maybe a, Maybe a, Maybe a)

--------------------------------------------------------------------------------
-- | A function that can rearrange a triple.
type Arrange a = Read3 a -> Read3 a

--------------------------------------------------------------------------------
-- | Extract all possible date combinations from the given text.
dateSansSep :: Text -> [YMD]
dateSansSep :: Text -> [YMD]
dateSansSep Text
t
  | Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isDigit Text
t) = []
  | Bool
otherwise = [Maybe YMD] -> [YMD]
forall a. [Maybe a] -> [a]
catMaybes
  [ YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
1, Int
2) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
1) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
0) Arrange Int
forall (f :: * -> *) a a b c.
(Applicative f, Num a) =>
(a, b, c) -> (a, b, f a)
ym_
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
0) Arrange Int
forall (f :: * -> *) a b a c.
(Applicative f, Num a) =>
(b, a, c) -> (a, b, f a)
my_
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
2, Int
2) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
2) Arrange Int
forall b c a. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
1) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
2) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
1, Int
4) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
1, Int
4) Arrange Int
forall b c a. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
2) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
2) Arrange Int
forall b c a. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
2) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
1, Int
1) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
2, Int
4) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
2, Int
4) Arrange Int
forall b c a. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
4) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
4) Arrange Int
forall b c a. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
1, Int
2) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
2, Int
1) Arrange Int
forall a. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
4) Arrange Int
forall c b a. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
4) Arrange Int
forall b c a. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
2, Int
2) Arrange Int
forall a. a -> a
ymd
  ]

  where
    -- Parse three numbers and reorder them.
    take3 :: (Int, Int, Int) -> Arrange Int -> Maybe YMD
    take3 :: YMD -> Arrange Int -> Maybe YMD
take3 (Int
x,Int
y,Int
z) Arrange Int
f
      | (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
z) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Int
Text.length Text
t = Maybe YMD
forall a. Maybe a
Nothing
      | Bool
otherwise =
        let g :: (Text, Text, Text) -> Maybe YMD
g = Read3 Int -> Maybe YMD
seq3 (Read3 Int -> Maybe YMD)
-> ((Text, Text, Text) -> Read3 Int)
-> (Text, Text, Text)
-> Maybe YMD
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arrange Int
f Arrange Int
-> ((Text, Text, Text) -> Read3 Int)
-> (Text, Text, Text)
-> Read3 Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text, Text) -> Read3 Int
read3
        in (Text, Text, Text) -> Maybe YMD
g ( Int -> Text -> Text
Text.take Int
x Text
t
             , Int -> Text -> Text
Text.take Int
y (Int -> Text -> Text
Text.drop Int
x Text
t)
             , Int -> Text -> Text
Text.drop (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
y) Text
t
             )

    -- Parser.
    read3 :: (Text, Text, Text) -> Read3 Int
    read3 :: (Text, Text, Text) -> Read3 Int
read3 (Text
x, Text
y, Text
z) =
      let r :: Text -> Maybe Int
r = (String -> Maybe Int)
-> ((Int, Text) -> Maybe Int)
-> Either String (Int, Text)
-> Maybe Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Int -> String -> Maybe Int
forall a b. a -> b -> a
const Maybe Int
forall a. Maybe a
Nothing) (Int, Text) -> Maybe Int
forall a. (a, Text) -> Maybe a
check (Either String (Int, Text) -> Maybe Int)
-> (Text -> Either String (Int, Text)) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String (Int, Text)
forall a. Integral a => Reader a
Text.decimal
          check :: (a, Text) -> Maybe a
check (a
n,Text
e) | Text -> Bool
Text.null Text
e = a -> Maybe a
forall a. a -> Maybe a
Just a
n
                      | Bool
otherwise   = Maybe a
forall a. Maybe a
Nothing
      in (Text -> Maybe Int
r Text
x, Text -> Maybe Int
r Text
y, Text -> Maybe Int
r Text
z)

    -- Sequence for a triple.
    seq3 :: Read3 Int -> Maybe YMD
    seq3 :: Read3 Int -> Maybe YMD
seq3 (Maybe Int
x, Maybe Int
y, Maybe Int
z) = (,,) (Int -> Int -> Int -> YMD)
-> Maybe Int -> Maybe (Int -> Int -> YMD)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
x Maybe (Int -> Int -> YMD) -> Maybe Int -> Maybe (Int -> YMD)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
y Maybe (Int -> YMD) -> Maybe Int -> Maybe YMD
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
z

    -- Arrangement functions.
    dmy :: (c, b, a) -> (a, b, c)
dmy (c
d,b
m,a
y) = (a
y,b
m,c
d)
    mdy :: (b, c, a) -> (a, b, c)
mdy (b
m,c
d,a
y) = (a
y,b
m,c
d)
    ym_ :: (a, b, c) -> (a, b, f a)
ym_ (a
y,b
m,c
_) = (a
y,b
m, a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
1)
    my_ :: (b, a, c) -> (a, b, f a)
my_ (b
m,a
y,c
_) = (a
y,b
m, a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
1)
    ymd :: a -> a
ymd         = a -> a
forall a. a -> a
id

--------------------------------------------------------------------------------
-- | Extract all possible date combinations that include component
-- separators.
dateAvecSep :: Atto.Parser [YMD]
dateAvecSep :: Parser [YMD]
dateAvecSep = do
    Int
ds1 <- Parser Int
forall a. Integral a => Parser a
Atto.decimal
    Char
sep <- (Char -> Bool) -> Parser Char
Atto.satisfy Char -> Bool
isSep
    Int
ds2 <- Parser Int
forall a. Integral a => Parser a
Atto.decimal
    Char
_   <- Char -> Parser Char
Atto.char Char
sep
    Int
ds3 <- Parser Int
forall a. Integral a => Parser a
Atto.decimal
    Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput

    [YMD] -> Parser [YMD]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (Int
ds1, Int
ds2, Int
ds3) -- Y-M-D
         , (Int
ds3, Int
ds2, Int
ds1) -- D-M-Y
         , (Int
ds3, Int
ds1, Int
ds2) -- M-D-Y
         ]
  where
    isSep :: Char -> Bool
    isSep :: Char -> Bool
isSep Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
||
              Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'  Bool -> Bool -> Bool
||
              Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
||
              Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'  Bool -> Bool -> Bool
||
              Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'  Bool -> Bool -> Bool
||
              Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'