{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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 (NoTimestamp)
  , 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).
data Timestamp = NoTimestamp | 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
$c== :: Timestamp -> Timestamp -> Bool
== :: Timestamp -> Timestamp -> Bool
$c/= :: Timestamp -> Timestamp -> Bool
/= :: 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
$ccompare :: Timestamp -> Timestamp -> Ordering
compare :: Timestamp -> Timestamp -> Ordering
$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
>= :: Timestamp -> Timestamp -> Bool
$cmax :: Timestamp -> Timestamp -> Timestamp
max :: Timestamp -> Timestamp -> Timestamp
$cmin :: Timestamp -> Timestamp -> Timestamp
min :: Timestamp -> Timestamp -> Timestamp
Ord, Timestamp -> ()
(Timestamp -> ()) -> NFData Timestamp
forall a. (a -> ()) -> NFData a
$crnf :: Timestamp -> ()
rnf :: Timestamp -> ()
NFData, Int -> Timestamp -> ShowS
[Timestamp] -> ShowS
Timestamp -> [Char]
(Int -> Timestamp -> ShowS)
-> (Timestamp -> [Char])
-> ([Timestamp] -> ShowS)
-> Show Timestamp
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Timestamp -> ShowS
showsPrec :: Int -> Timestamp -> ShowS
$cshow :: Timestamp -> [Char]
show :: Timestamp -> [Char]
$cshowList :: [Timestamp] -> ShowS
showList :: [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
$cfrom :: forall x. Timestamp -> Rep Timestamp x
from :: forall x. Timestamp -> Rep Timestamp x
$cto :: forall x. Rep Timestamp x -> Timestamp
to :: forall x. Rep Timestamp x -> Timestamp
Generic)

epochTimeToTimestamp :: Tar.EpochTime -> Timestamp
epochTimeToTimestamp :: Int64 -> Timestamp
epochTimeToTimestamp = Int64 -> Timestamp
TS

timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime Timestamp
NoTimestamp = Maybe UTCTime
forall a. Maybe a
Nothing
timestampToUTCTime (TS Int64
t) = 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 (Int64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
t)

utcTimeToTimestamp :: UTCTime -> Timestamp
utcTimeToTimestamp :: UTCTime -> Timestamp
utcTimeToTimestamp =
  Int64 -> Timestamp
TS
    (Int64 -> Timestamp) -> (UTCTime -> Int64) -> UTCTime -> Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Integer -> Int64)
    (Integer -> Int64) -> (UTCTime -> Integer) -> UTCTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
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

-- | Compute the maximum 'Timestamp' value
--
-- Returns 'NoTimestamp' for the empty list.  Also note that
-- 'NoTimestamp' compares as smaller to all non-'NoTimestamp'
-- values.
maximumTimestamp :: [Timestamp] -> Timestamp
maximumTimestamp :: [Timestamp] -> Timestamp
maximumTimestamp [] = Timestamp
NoTimestamp
maximumTimestamp xs :: [Timestamp]
xs@(Timestamp
_ : [Timestamp]
_) = [Timestamp] -> Timestamp
forall a. Ord a => [a] -> a
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 (Int64 -> Timestamp
TS (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
pt))
  | Bool
otherwise = Maybe Timestamp
forall a. Maybe a
Nothing
  where
    maxTs :: Integer
maxTs = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64)
    minTs :: Integer
minTs = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Int64
forall a. Enum a => a -> a
succ Int64
forall a. Bounded a => a
minBound :: Int64)

-- | Pretty-prints non-null 'Timestamp' in ISO8601/RFC3339 format
-- (e.g. @"2017-12-31T23:59:59Z"@).
showTimestamp :: Timestamp -> String
showTimestamp :: Timestamp -> [Char]
showTimestamp Timestamp
ts = case Timestamp -> Maybe UTCTime
timestampToUTCTime Timestamp
ts of
  Maybe UTCTime
Nothing -> [Char]
"Unknown or invalid timestamp"
  -- Note: we don't use 'formatTime' here to avoid incurring a
  -- dependency on 'old-locale' for older `time` libs
  Just UTCTime{Day
DiffTime
utctDay :: Day
utctDayTime :: DiffTime
utctDay :: UTCTime -> Day
utctDayTime :: UTCTime -> DiffTime
..} -> Day -> [Char]
showGregorian Day
utctDay [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
'T' Char -> ShowS
forall a. a -> [a] -> [a]
: DiffTime -> [Char]
showTOD DiffTime
utctDayTime) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Z"
  where
    showTOD :: DiffTime -> [Char]
showTOD = TimeOfDay -> [Char]
forall a. Show a => a -> [Char]
show (TimeOfDay -> [Char])
-> (DiffTime -> TimeOfDay) -> DiffTime -> [Char]
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 = [Char] -> Doc
Disp.text ([Char] -> Doc) -> (Timestamp -> [Char]) -> Timestamp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> [Char]
showTimestamp

instance Parsec Timestamp where
  parsec :: forall (m :: * -> *). CabalParsing m => m Timestamp
parsec = m Timestamp
parsePosix m Timestamp -> m Timestamp -> m Timestamp
forall a. m a -> m a -> m a
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 -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'@'
        t <- P.integral -- note, no negative timestamps
        maybe (fail (show t ++ " is not representable as timestamp")) return $
          posixSecondsToTimestamp 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.

        ye <- m Integer
parseYear
        _ <- P.char '-'
        mo <- parseTwoDigits
        _ <- P.char '-'
        da <- parseTwoDigits
        _ <- P.char 'T'

        utctDay <-
          maybe (fail (show (ye, mo, da) ++ " is not valid gregorian date")) return $
            fromGregorianValid ye mo da

        ho <- parseTwoDigits
        _ <- P.char ':'
        mi <- parseTwoDigits
        _ <- P.char ':'
        se <- parseTwoDigits
        _ <- P.char 'Z'

        utctDayTime <-
          maybe (fail (show (ho, mi, se) ++ " is not valid time of day")) (return . timeOfDayToTime) $
            makeTimeOfDayValid ho mi (realToFrac (se :: Int))

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

        return $ utcTimeToTimestamp utc

      parseTwoDigits :: m Int
parseTwoDigits = do
        d1 <- (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isDigit
        d2 <- P.satisfy isDigit
        return (read [d1, 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
        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
'-')
        ds <- P.munch1 isDigit
        when (length ds < 4) $ fail "Year should have at least 4 digits"
        return (read (sign : ds))