{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.IndexUtils.Timestamp
( Timestamp
, nullTimestamp
, 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
newtype Timestamp = TS Int64
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
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
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)
showTimestamp :: Timestamp -> String
showTimestamp :: Timestamp -> String
showTimestamp Timestamp
ts = case Timestamp -> Maybe UTCTime
timestampToUTCTime Timestamp
ts of
Maybe UTCTime
Nothing -> String
""
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
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 (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
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 (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])
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))
nullTimestamp :: Timestamp
nullTimestamp :: Timestamp
nullTimestamp = EpochTime -> Timestamp
TS EpochTime
forall a. Bounded a => a
minBound