{-# 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
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
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
Ord,Int -> Timestamp
Timestamp -> Int
Timestamp -> [Timestamp]
Timestamp -> Timestamp
Timestamp -> Timestamp -> [Timestamp]
Timestamp -> Timestamp -> Timestamp -> [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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: Timestamp -> ()
$crnf :: Timestamp -> ()
NFData,Int -> Timestamp -> ShowS
[Timestamp] -> ShowS
Timestamp -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Timestamp] -> ShowS
$cshowList :: [Timestamp] -> ShowS
show :: Timestamp -> [Char]
$cshow :: Timestamp -> [Char]
showsPrec :: Int -> Timestamp -> ShowS
$cshowsPrec :: Int -> Timestamp -> ShowS
Show,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 :: Int64 -> Maybe Timestamp
epochTimeToTimestamp Int64
et
  | Timestamp
ts forall a. Eq a => a -> a -> Bool
== Timestamp
nullTimestamp  = forall a. Maybe a
Nothing
  | Bool
otherwise            = forall a. a -> Maybe a
Just Timestamp
ts
  where
    ts :: Timestamp
ts = Int64 -> Timestamp
TS Int64
et

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

utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp UTCTime
utct
  | Integer
minTime forall a. Ord a => a -> a -> Bool
<= Integer
t, Integer
t forall a. Ord a => a -> a -> Bool
<= Integer
maxTime  = forall a. a -> Maybe a
Just (Int64 -> Timestamp
TS (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t))
  | Bool
otherwise                   = forall a. Maybe a
Nothing
  where
    maxTime :: Integer
maxTime = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int64)
    minTime :: Integer
minTime = forall a. Integral a => a -> Integer
toInteger (forall a. Enum a => a -> a
succ forall a. Bounded a => a
minBound :: Int64)
    t :: Integer
    t :: Integer
t = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds 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]
_) = 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 forall a. Ord a => a -> a -> Bool
<= Integer
pt, Integer
pt forall a. Ord a => a -> a -> Bool
<= Integer
maxTs  = forall a. a -> Maybe a
Just (Int64 -> Timestamp
TS (forall a. Num a => Integer -> a
fromInteger Integer
pt))
  | Bool
otherwise                 = forall a. Maybe a
Nothing
  where
    maxTs :: Integer
maxTs = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int64)
    minTs :: Integer
minTs = forall a. Integral a => a -> Integer
toInteger (forall a. Enum a => a -> a
succ 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 -> [Char]
showTimestamp Timestamp
ts = case Timestamp -> Maybe UTCTime
timestampToUTCTime Timestamp
ts of
    Maybe UTCTime
Nothing          -> [Char]
""
    -- 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 -> [Char]
showGregorian Day
utctDay forall a. [a] -> [a] -> [a]
++ (Char
'T'forall a. a -> [a] -> [a]
:DiffTime -> [Char]
showTOD DiffTime
utctDayTime) forall a. [a] -> [a] -> [a]
++ [Char]
"Z"
  where
    showTOD :: DiffTime -> [Char]
showTOD = forall a. Show a => a -> [Char]
show 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 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 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
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'@'
            Integer
t <- forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
P.integral -- note, no negative timestamps
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall a. Show a => a -> [Char]
show Integer
t forall a. [a] -> [a] -> [a]
++ [Char]
" is not representable as timestamp")) forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
            Int
mo   <- m Int
parseTwoDigits
            Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
            Int
da   <- m Int
parseTwoDigits
            Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'T'

            Day
utctDay <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall a. Show a => a -> [Char]
show (Integer
ye,Int
mo,Int
da) forall a. [a] -> [a] -> [a]
++ [Char]
" is not valid gregorian date")) forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
            Int
mi   <- m Int
parseTwoDigits
            Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
            Int
se   <- m Int
parseTwoDigits
            Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'Z'

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

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

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

        parseTwoDigits :: m Int
parseTwoDigits = do
            Char
d1 <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isDigit
            Char
d2 <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isDigit
            forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Char
' ' (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-')
            [Char]
ds <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m [Char]
P.munch1 Char -> Bool
isDigit
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ds forall a. Ord a => a -> a -> Bool
< Int
4) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Year should have at least 4 digits"
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => [Char] -> a
read (Char
signforall a. a -> [a] -> [a]
:[Char]
ds))

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