{-# 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
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 forall s a. s -> Getting a s a -> a
^. Lens' Date Int
year, Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Int
month, Date
d forall s a. s -> Getting a s a -> a
^. 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 =
  forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
    [Date] -> [Date]
order forall a b. (a -> b) -> a -> b
$
      forall a. (a -> Bool) -> [a] -> [a]
filter Date -> Bool
valid forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map Date -> Date
fixYear [Date]
dates
  where
    dates :: [Date]
    dates :: [Date]
dates =
      case 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [YMD]
ds

    order :: [Date] -> [Date]
    order :: [Date] -> [Date]
order = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare 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 = forall a. Num a => a -> a
abs (forall a. Integral a => a -> Integer
toInteger (Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Int
year) forall a. Num a => a -> a -> a
- Integer
refY)

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

    fixYear :: Date -> Date
    fixYear :: Date -> Date
fixYear Date
d | (Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Int
year) forall a. Ord a => a -> a -> Bool
> Int
99 = Date
d
              | (Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Int
year) forall a. Ord a => a -> a -> Bool
> Int
50 = Date
d forall a b. a -> (a -> b) -> b
& Lens' Date Int
year forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
lastCentury
              | Bool
otherwise        = Date
d forall a b. a -> (a -> b) -> b
& Lens' Date Int
year 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 forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
_1

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

    thisCentury :: Int
    thisCentury :: Int
thisCentury = forall a. Num a => Integer -> a
fromInteger Integer
refY forall a. Integral a => a -> a -> a
`div` Int
100 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 = forall a. Ord a => a -> a -> a
max (forall a. Num a => a -> a
abs (forall a. Integral a => a -> Integer
toInteger (Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Int
year) forall a. Num a => a -> a -> a
- (Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Integer
refYear))) Integer
20
      guesses :: Integer
guesses = forall a. Ord a => a -> a -> a
max Integer
1 Integer
space forall a. Num a => a -> a -> a
* Integer
365
  in if Date
d forall s a. s -> Getting a s a -> a
^. Lens' Date Bool
hasSep
       then Integer
guesses 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 = forall a. [Maybe a] -> [a]
catMaybes
  [ YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
1, Int
2) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
1) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
0) 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) 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) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
2) forall {b} {c} {a}. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
1) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
2) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
1, Int
4) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
1, Int
4) forall {b} {c} {a}. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
2) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
2) forall {b} {c} {a}. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
2) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
1, Int
1) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
2, Int
4) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
1, Int
2, Int
4) forall {b} {c} {a}. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
4) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
1, Int
4) forall {b} {c} {a}. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
1, Int
2) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
2, Int
1) forall {a}. a -> a
ymd
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
4) forall {c} {b} {a}. (c, b, a) -> (a, b, c)
dmy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
2, Int
2, Int
4) forall {b} {c} {a}. (b, c, a) -> (a, b, c)
mdy
  , YMD -> Arrange Int -> Maybe YMD
take3 (Int
4, Int
2, Int
2) 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
xforall a. Num a => a -> a -> a
+Int
yforall a. Num a => a -> a -> a
+Int
z) forall a. Eq a => a -> a -> Bool
/= Text -> Int
Text.length Text
t = forall a. Maybe a
Nothing
      | Bool
otherwise =
        let g :: (Text, Text, Text) -> Maybe YMD
g = Read3 Int -> Maybe YMD
seq3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arrange Int
f 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
xforall 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall {a}. (a, Text) -> Maybe a
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Reader a
Text.decimal
          check :: (a, Text) -> Maybe a
check (a
n,Text
e) | Text -> Bool
Text.null Text
e = forall a. a -> Maybe a
Just a
n
                      | Bool
otherwise   = 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) = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
y 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, 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, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
1)
    ymd :: a -> a
ymd         = 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 <- forall a. Integral a => Parser a
Atto.decimal
    Char
sep <- (Char -> Bool) -> Parser Char
Atto.satisfy Char -> Bool
isSep
    Int
ds2 <- forall a. Integral a => Parser a
Atto.decimal
    Char
_   <- Char -> Parser Char
Atto.char Char
sep
    Int
ds3 <- forall a. Integral a => Parser a
Atto.decimal
    forall t. Chunk t => Parser t ()
Atto.endOfInput

    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 forall a. Eq a => a -> a -> Bool
== Char
'/'  Bool -> Bool -> Bool
||
              Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
||
              Char
c forall a. Eq a => a -> a -> Bool
== Char
'.'  Bool -> Bool -> Bool
||
              Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'  Bool -> Bool -> Bool
||
              Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'