{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.IndexUtils.Timestamp
( Timestamp (NoTimestamp)
, epochTimeToTimestamp
, timestampToUTCTime
, utcTimeToTimestamp
, maximumTimestamp
) where
import Distribution.Client.Compat.Prelude
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
data Timestamp = NoTimestamp | TS Int64
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
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
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)
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"
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
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
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
parseUTC :: m Timestamp
parseUTC = do
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])
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))