{-# 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
_ <- 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 ([Char] -> m Timestamp
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not representable as timestamp")) Timestamp -> m Timestamp
forall a. a -> m a
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 ([Char] -> m Day
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ((Integer, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Integer
ye, Int
mo, Int
da) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not valid gregorian date")) Day -> m Day
forall a. a -> m a
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 ([Char] -> m DiffTime
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ((Int, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
ho, Int
mi, Int
se) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not valid time of day")) (DiffTime -> m DiffTime
forall a. a -> m a
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
utctDay :: Day
utctDayTime :: DiffTime
utctDay :: Day
utctDayTime :: DiffTime
..}

        Timestamp -> m Timestamp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Timestamp -> m Timestamp) -> Timestamp -> m Timestamp
forall a b. (a -> b) -> a -> b
$ UTCTime -> 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Int
forall a. Read a => [Char] -> 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
'-')
        [Char]
ds <- (Char -> Bool) -> m [Char]
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m [Char]
P.munch1 Char -> Bool
isDigit
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Year should have at least 4 digits"
        Integer -> m Integer
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Integer
forall a. Read a => [Char] -> a
read (Char
sign Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
ds))