{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.IndexUtils.Timestamp
-- Copyright   :  (c) 2016 Herbert Valerio Riedel
-- License     :  BSD3
--
-- Timestamp type used in package indexes

module Distribution.Client.IndexUtils.Timestamp
    ( Timestamp
    , nullTimestamp
    , epochTimeToTimestamp
    , timestampToUTCTime
    , utcTimeToTimestamp
    , maximumTimestamp
    ) where

import Distribution.Client.Compat.Prelude

-- read is needed for Text instance
import Prelude (read)

import Data.Time             (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)

import qualified Codec.Archive.Tar.Entry         as Tar
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint                as Disp

-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
newtype Timestamp = TS Int64 -- Tar.EpochTime
                  deriving (Timestamp -> Timestamp -> Bool
(Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool) -> Eq Timestamp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Timestamp -> Timestamp -> Bool
$c/= :: Timestamp -> Timestamp -> Bool
== :: Timestamp -> Timestamp -> Bool
$c== :: Timestamp -> Timestamp -> Bool
Eq,Eq Timestamp
Eq Timestamp
-> (Timestamp -> Timestamp -> Ordering)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Timestamp)
-> (Timestamp -> Timestamp -> Timestamp)
-> Ord Timestamp
Timestamp -> Timestamp -> Bool
Timestamp -> Timestamp -> Ordering
Timestamp -> Timestamp -> Timestamp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Timestamp -> Timestamp -> Timestamp
$cmin :: Timestamp -> Timestamp -> Timestamp
max :: Timestamp -> Timestamp -> Timestamp
$cmax :: Timestamp -> Timestamp -> Timestamp
>= :: Timestamp -> Timestamp -> Bool
$c>= :: Timestamp -> Timestamp -> Bool
> :: Timestamp -> Timestamp -> Bool
$c> :: Timestamp -> Timestamp -> Bool
<= :: Timestamp -> Timestamp -> Bool
$c<= :: Timestamp -> Timestamp -> Bool
< :: Timestamp -> Timestamp -> Bool
$c< :: Timestamp -> Timestamp -> Bool
compare :: Timestamp -> Timestamp -> Ordering
$ccompare :: Timestamp -> Timestamp -> Ordering
$cp1Ord :: Eq Timestamp
Ord,Int -> Timestamp
Timestamp -> Int
Timestamp -> [Timestamp]
Timestamp -> Timestamp
Timestamp -> Timestamp -> [Timestamp]
Timestamp -> Timestamp -> Timestamp -> [Timestamp]
(Timestamp -> Timestamp)
-> (Timestamp -> Timestamp)
-> (Int -> Timestamp)
-> (Timestamp -> Int)
-> (Timestamp -> [Timestamp])
-> (Timestamp -> Timestamp -> [Timestamp])
-> (Timestamp -> Timestamp -> [Timestamp])
-> (Timestamp -> Timestamp -> Timestamp -> [Timestamp])
-> Enum Timestamp
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Timestamp -> Timestamp -> Timestamp -> [Timestamp]
$cenumFromThenTo :: Timestamp -> Timestamp -> Timestamp -> [Timestamp]
enumFromTo :: Timestamp -> Timestamp -> [Timestamp]
$cenumFromTo :: Timestamp -> Timestamp -> [Timestamp]
enumFromThen :: Timestamp -> Timestamp -> [Timestamp]
$cenumFromThen :: Timestamp -> Timestamp -> [Timestamp]
enumFrom :: Timestamp -> [Timestamp]
$cenumFrom :: Timestamp -> [Timestamp]
fromEnum :: Timestamp -> Int
$cfromEnum :: Timestamp -> Int
toEnum :: Int -> Timestamp
$ctoEnum :: Int -> Timestamp
pred :: Timestamp -> Timestamp
$cpred :: Timestamp -> Timestamp
succ :: Timestamp -> Timestamp
$csucc :: Timestamp -> Timestamp
Enum,Timestamp -> ()
(Timestamp -> ()) -> NFData Timestamp
forall a. (a -> ()) -> NFData a
rnf :: Timestamp -> ()
$crnf :: Timestamp -> ()
NFData,Int -> Timestamp -> ShowS
[Timestamp] -> ShowS
Timestamp -> String
(Int -> Timestamp -> ShowS)
-> (Timestamp -> String)
-> ([Timestamp] -> ShowS)
-> Show Timestamp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Timestamp] -> ShowS
$cshowList :: [Timestamp] -> ShowS
show :: Timestamp -> String
$cshow :: Timestamp -> String
showsPrec :: Int -> Timestamp -> ShowS
$cshowsPrec :: Int -> Timestamp -> ShowS
Show,(forall x. Timestamp -> Rep Timestamp x)
-> (forall x. Rep Timestamp x -> Timestamp) -> Generic Timestamp
forall x. Rep Timestamp x -> Timestamp
forall x. Timestamp -> Rep Timestamp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Timestamp x -> Timestamp
$cfrom :: forall x. Timestamp -> Rep Timestamp x
Generic)

epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp
epochTimeToTimestamp :: EpochTime -> Maybe Timestamp
epochTimeToTimestamp EpochTime
et
  | Timestamp
ts Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
== Timestamp
nullTimestamp  = Maybe Timestamp
forall a. Maybe a
Nothing
  | Bool
otherwise            = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
ts
  where
    ts :: Timestamp
ts = EpochTime -> Timestamp
TS EpochTime
et

timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime (TS EpochTime
t)
  | EpochTime
t EpochTime -> EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
== EpochTime
forall a. Bounded a => a
minBound  = Maybe UTCTime
forall a. Maybe a
Nothing
  | Bool
otherwise      = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (EpochTime -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral EpochTime
t)

utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp UTCTime
utct
  | Integer
minTime Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
t, Integer
t Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxTime  = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just (EpochTime -> Timestamp
TS (Integer -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t))
  | Bool
otherwise                   = Maybe Timestamp
forall a. Maybe a
Nothing
  where
    maxTime :: Integer
maxTime = EpochTime -> Integer
forall a. Integral a => a -> Integer
toInteger (EpochTime
forall a. Bounded a => a
maxBound :: Int64)
    minTime :: Integer
minTime = EpochTime -> Integer
forall a. Integral a => a -> Integer
toInteger (EpochTime -> EpochTime
forall a. Enum a => a -> a
succ EpochTime
forall a. Bounded a => a
minBound :: Int64)
    t :: Integer
    t :: Integer
t = POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer)
-> (UTCTime -> POSIXTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> Integer) -> UTCTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime
utct

-- | Compute the maximum 'Timestamp' value
--
-- Returns 'nullTimestamp' for the empty list.  Also note that
-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp'
-- values.
maximumTimestamp :: [Timestamp] -> Timestamp
maximumTimestamp :: [Timestamp] -> Timestamp
maximumTimestamp [] = Timestamp
nullTimestamp
maximumTimestamp xs :: [Timestamp]
xs@(Timestamp
_:[Timestamp]
_) = [Timestamp] -> Timestamp
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Timestamp]
xs

-- returns 'Nothing' if not representable as 'Timestamp'
posixSecondsToTimestamp :: Integer -> Maybe Timestamp
posixSecondsToTimestamp :: Integer -> Maybe Timestamp
posixSecondsToTimestamp Integer
pt
  | Integer
minTs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
pt, Integer
pt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxTs  = Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just (EpochTime -> Timestamp
TS (Integer -> EpochTime
forall a. Num a => Integer -> a
fromInteger Integer
pt))
  | Bool
otherwise                 = Maybe Timestamp
forall a. Maybe a
Nothing
  where
    maxTs :: Integer
maxTs = EpochTime -> Integer
forall a. Integral a => a -> Integer
toInteger (EpochTime
forall a. Bounded a => a
maxBound :: Int64)
    minTs :: Integer
minTs = EpochTime -> Integer
forall a. Integral a => a -> Integer
toInteger (EpochTime -> EpochTime
forall a. Enum a => a -> a
succ EpochTime
forall a. Bounded a => a
minBound :: Int64)

-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format
-- (e.g. @"2017-12-31T23:59:59Z"@)
--
-- Returns empty string for 'nullTimestamp' in order for
--
-- > null (display nullTimestamp) == True
--
-- to hold.
showTimestamp :: Timestamp -> String
showTimestamp :: Timestamp -> String
showTimestamp Timestamp
ts = case Timestamp -> Maybe UTCTime
timestampToUTCTime Timestamp
ts of
    Maybe UTCTime
Nothing          -> String
""
    -- Note: we don't use 'formatTime' here to avoid incurring a
    -- dependency on 'old-locale' for older `time` libs
    Just UTCTime{DiffTime
Day
utctDay :: UTCTime -> Day
utctDayTime :: UTCTime -> DiffTime
utctDayTime :: DiffTime
utctDay :: Day
..} -> Day -> String
showGregorian Day
utctDay String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
'T'Char -> ShowS
forall a. a -> [a] -> [a]
:DiffTime -> String
showTOD DiffTime
utctDayTime) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Z"
  where
    showTOD :: DiffTime -> String
showTOD = TimeOfDay -> String
forall a. Show a => a -> String
show (TimeOfDay -> String)
-> (DiffTime -> TimeOfDay) -> DiffTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> TimeOfDay
timeToTimeOfDay

instance Binary Timestamp
instance Structured Timestamp

instance Pretty Timestamp where
    pretty :: Timestamp -> Doc
pretty = String -> Doc
Disp.text (String -> Doc) -> (Timestamp -> String) -> Timestamp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> String
showTimestamp

instance Parsec Timestamp where
    parsec :: m Timestamp
parsec = m Timestamp
parsePosix m Timestamp -> m Timestamp -> m Timestamp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Timestamp
parseUTC
      where
        -- | Parses unix timestamps, e.g. @"\@1474626019"@
        parsePosix :: m Timestamp
parsePosix = do
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'@'
            Integer
t <- m Integer
forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
P.integral -- note, no negative timestamps
            m Timestamp
-> (Timestamp -> m Timestamp) -> Maybe Timestamp -> m Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Timestamp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Integer -> String
forall a. Show a => a -> String
show Integer
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not representable as timestamp")) Timestamp -> m Timestamp
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Timestamp -> m Timestamp) -> Maybe Timestamp -> m Timestamp
forall a b. (a -> b) -> a -> b
$
                Integer -> Maybe Timestamp
posixSecondsToTimestamp Integer
t

        -- | Parses ISO8601/RFC3339-style UTC timestamps,
        -- e.g. @"2017-12-31T23:59:59Z"@
        --
        -- TODO: support numeric tz offsets; allow to leave off seconds
        parseUTC :: m Timestamp
parseUTC = do
            -- Note: we don't use 'Data.Time.Format.parseTime' here since
            -- we want more control over the accepted formats.

            Integer
ye <- m Integer
parseYear
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
            Int
mo   <- m Int
parseTwoDigits
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
            Int
da   <- m Int
parseTwoDigits
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'T'

            Day
utctDay <- m Day -> (Day -> m Day) -> Maybe Day -> m Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Day
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ((Integer, Int, Int) -> String
forall a. Show a => a -> String
show (Integer
ye,Int
mo,Int
da) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not valid gregorian date")) Day -> m Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Day -> m Day) -> Maybe Day -> m Day
forall a b. (a -> b) -> a -> b
$
                       Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
ye Int
mo Int
da

            Int
ho   <- m Int
parseTwoDigits
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
            Int
mi   <- m Int
parseTwoDigits
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
            Int
se   <- m Int
parseTwoDigits
            Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'Z'

            DiffTime
utctDayTime <- m DiffTime
-> (TimeOfDay -> m DiffTime) -> Maybe TimeOfDay -> m DiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m DiffTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ((Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int
ho,Int
mi,Int
se) String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
" is not valid time of day")) (DiffTime -> m DiffTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DiffTime -> m DiffTime)
-> (TimeOfDay -> DiffTime) -> TimeOfDay -> m DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> DiffTime
timeOfDayToTime) (Maybe TimeOfDay -> m DiffTime) -> Maybe TimeOfDay -> m DiffTime
forall a b. (a -> b) -> a -> b
$
                           Int -> Int -> Pico -> Maybe TimeOfDay
makeTimeOfDayValid Int
ho Int
mi (Int -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Int
se::Int))

            let utc :: UTCTime
utc = UTCTime :: Day -> DiffTime -> UTCTime
UTCTime {DiffTime
Day
utctDayTime :: DiffTime
utctDay :: Day
utctDay :: Day
utctDayTime :: DiffTime
..}

            m Timestamp
-> (Timestamp -> m Timestamp) -> Maybe Timestamp -> m Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Timestamp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
utc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not representable as timestamp")) Timestamp -> m Timestamp
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Timestamp -> m Timestamp) -> Maybe Timestamp -> m Timestamp
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe Timestamp
utcTimeToTimestamp UTCTime
utc

        parseTwoDigits :: m Int
parseTwoDigits = do
            Char
d1 <- (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isDigit
            Char
d2 <- (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isDigit
            Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int
forall a. Read a => String -> a
read [Char
d1,Char
d2])

        -- A year must have at least 4 digits; e.g. "0097" is fine,
        -- while "97" is not c.f. RFC3339 which
        -- deprecates 2-digit years
        parseYear :: m Integer
parseYear = do
            Char
sign <- Char -> m Char -> m Char
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Char
' ' (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-')
            String
ds <- (Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
P.munch1 Char -> Bool
isDigit
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Year should have at least 4 digits"
            Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Integer
forall a. Read a => String -> a
read (Char
signChar -> ShowS
forall a. a -> [a] -> [a]
:String
ds))

-- | Special timestamp value to be used when 'timestamp' is
-- missing/unknown/invalid
nullTimestamp :: Timestamp
nullTimestamp :: Timestamp
nullTimestamp = EpochTime -> Timestamp
TS EpochTime
forall a. Bounded a => a
minBound