cabal-install-3.0.0.0: Distribution/Client/IndexUtils/Timestamp.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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
, IndexState(..)
) where
import qualified Codec.Archive.Tar.Entry as Tar
import Control.DeepSeq
import Control.Monad
import Data.Char (isDigit)
import Data.Int (Int64)
import Data.Time (UTCTime (..), fromGregorianValid,
makeTimeOfDayValid, showGregorian,
timeOfDayToTime, timeToTimeOfDay)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime,
utcTimeToPOSIXSeconds)
import Distribution.Compat.Binary
import qualified Distribution.Deprecated.ReadP as ReadP
import Distribution.Deprecated.Text
import qualified Text.PrettyPrint as Disp
import GHC.Generics (Generic)
-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
newtype Timestamp = TS Int64 -- Tar.EpochTime
deriving (Eq,Ord,Enum,NFData,Show,Generic)
epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp
epochTimeToTimestamp et
| ts == nullTimestamp = Nothing
| otherwise = Just ts
where
ts = TS et
timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime (TS t)
| t == minBound = Nothing
| otherwise = Just $ posixSecondsToUTCTime (fromIntegral t)
utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp utct
| minTime <= t, t <= maxTime = Just (TS (fromIntegral t))
| otherwise = Nothing
where
maxTime = toInteger (maxBound :: Int64)
minTime = toInteger (succ minBound :: Int64)
t :: Integer
t = round . utcTimeToPOSIXSeconds $ 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 [] = nullTimestamp
maximumTimestamp xs@(_:_) = maximum xs
-- returns 'Nothing' if not representable as 'Timestamp'
posixSecondsToTimestamp :: Integer -> Maybe Timestamp
posixSecondsToTimestamp pt
| minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt))
| otherwise = Nothing
where
maxTs = toInteger (maxBound :: Int64)
minTs = toInteger (succ 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 ts = case timestampToUTCTime ts of
Nothing -> ""
-- Note: we don't use 'formatTime' here to avoid incurring a
-- dependency on 'old-locale' for older `time` libs
Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z"
where
showTOD = show . timeToTimeOfDay
instance Binary Timestamp where
put (TS t) = put t
get = TS `fmap` get
instance Text Timestamp where
disp = Disp.text . showTimestamp
parse = parsePosix ReadP.+++ parseUTC
where
-- | Parses unix timestamps, e.g. @"\@1474626019"@
parsePosix = do
_ <- ReadP.char '@'
t <- parseInteger
maybe ReadP.pfail 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 = do
-- Note: we don't use 'Data.Time.Format.parseTime' here since
-- we want more control over the accepted formats.
ye <- parseYear
_ <- ReadP.char '-'
mo <- parseTwoDigits
_ <- ReadP.char '-'
da <- parseTwoDigits
_ <- ReadP.char 'T'
utctDay <- maybe ReadP.pfail return $
fromGregorianValid ye mo da
ho <- parseTwoDigits
_ <- ReadP.char ':'
mi <- parseTwoDigits
_ <- ReadP.char ':'
se <- parseTwoDigits
_ <- ReadP.char 'Z'
utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $
makeTimeOfDayValid ho mi (realToFrac (se::Int))
maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..})
parseTwoDigits = do
d1 <- ReadP.satisfy isDigit
d2 <- ReadP.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 = do
sign <- ReadP.option ' ' (ReadP.char '-')
ds <- ReadP.munch1 isDigit
when (length ds < 4) ReadP.pfail
return (read (sign:ds))
parseInteger = do
sign <- ReadP.option ' ' (ReadP.char '-')
ds <- ReadP.munch1 isDigit
return (read (sign:ds) :: Integer)
-- | Special timestamp value to be used when 'timestamp' is
-- missing/unknown/invalid
nullTimestamp :: Timestamp
nullTimestamp = TS minBound
----------------------------------------------------------------------------
-- defined here for now to avoid import cycles
-- | Specification of the state of a specific repo package index
data IndexState = IndexStateHead -- ^ Use all available entries
| IndexStateTime !Timestamp -- ^ Use all entries that existed at
-- the specified time
deriving (Eq,Generic,Show)
instance Binary IndexState
instance NFData IndexState
instance Text IndexState where
disp IndexStateHead = Disp.text "HEAD"
disp (IndexStateTime ts) = disp ts
parse = parseHead ReadP.+++ parseTime
where
parseHead = do
_ <- ReadP.string "HEAD"
return IndexStateHead
parseTime = IndexStateTime `fmap` parse