Commit 060b9061 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by GitHub
Browse files

Turn 'Timestamp' into a proper type (#3892)

Most notably, this allows us to provide a custom instance for `Text`
parent 902fae64
......@@ -38,6 +38,7 @@ import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.Types
import Distribution.Package
......@@ -76,9 +77,8 @@ import Distribution.Solver.Types.SourcePackage
import GHC.Generics (Generic)
import Data.Char (isAlphaNum)
import Data.Maybe (mapMaybe, catMaybes, maybeToList)
import Data.Maybe (mapMaybe, catMaybes, maybeToList, fromMaybe)
import Data.List (isPrefixOf)
import Data.Int (Int64)
import Data.Word
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
......@@ -495,7 +495,8 @@ withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =
]
where
blockNo = Sec.directoryEntryBlockNo dirEntry
timestamp = Sec.indexEntryTime sie
timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $
epochTimeToTimestamp $ Sec.indexEntryTime sie
withIndexEntries index callback = do -- non-secure repositories
withFile (indexFile index) ReadMode $ \h -> do
......@@ -504,9 +505,9 @@ withIndexEntries index callback = do -- non-secure repositories
callback $ map toCache (catMaybes pkgsOrPrefs)
where
toCache :: PackageOrDep -> IndexCacheEntry
toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo (-1)
toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp
toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
toCache (Dep d) = CachePreference d 0 (-1)
toCache (Dep d) = CachePreference d 0 nullTimestamp
data ReadPackageIndexMode = ReadPackageIndexStrict
| ReadPackageIndexLazyIO
......@@ -653,8 +654,6 @@ instance NFData Cache where
--
type BlockNo = Word32 -- Tar.TarEntryOffset
-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
type Timestamp = Int64 -- Tar.EpochTime
data IndexCacheEntry
= CachePackageId PackageId !BlockNo !Timestamp
......@@ -712,7 +711,8 @@ read00IndexCacheEntry = \line ->
case (parseName pkgnamestr, parseVer pkgverstr [],
parseBlockNo blocknostr) of
(Just pkgname, Just pkgver, Just blockno)
-> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno (-1))
-> Just (CachePackageId (PackageIdentifier pkgname pkgver)
blockno nullTimestamp)
_ -> Nothing
[key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
case (parseRefType typecodestr, parseBlockNo blocknostr) of
......@@ -722,7 +722,7 @@ read00IndexCacheEntry = \line ->
(key: remainder) | key == BSS.pack preferredVersionKey -> do
pref <- simpleParse (BSS.unpack (BSS.unwords remainder))
return $ CachePreference pref 0 (-1)
return $ CachePreference pref 0 nullTimestamp
_ -> Nothing
where
......
{-# 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
) 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.Compat.ReadP as ReadP
import Distribution.Text
import qualified Text.PrettyPrint as Disp
-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
newtype Timestamp = TS Int64 -- Tar.EpochTime
deriving (Eq,Ord,Enum,NFData,Show)
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
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
......@@ -263,6 +263,7 @@ executable cabal
Distribution.Client.Haddock
Distribution.Client.HttpUtils
Distribution.Client.IndexUtils
Distribution.Client.IndexUtils.Timestamp
Distribution.Client.Init
Distribution.Client.Init.Heuristics
Distribution.Client.Init.Licenses
......@@ -446,6 +447,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Client.UserConfig
UnitTests.Distribution.Client.ProjectConfig
UnitTests.Distribution.Client.JobControl
UnitTests.Distribution.Client.IndexUtils.Timestamp
UnitTests.Distribution.Client.InstallPlan
UnitTests.Distribution.Solver.Modular.PSQ
UnitTests.Distribution.Solver.Modular.RetryLog
......
......@@ -24,6 +24,7 @@ import qualified UnitTests.Distribution.Client.Targets
import qualified UnitTests.Distribution.Client.UserConfig
import qualified UnitTests.Distribution.Client.ProjectConfig
import qualified UnitTests.Distribution.Client.JobControl
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
import qualified UnitTests.Distribution.Client.InstallPlan
import UnitTests.Options
......@@ -65,6 +66,8 @@ tests mtimeChangeCalibrated =
UnitTests.Distribution.Client.ProjectConfig.tests
, testGroup "UnitTests.Distribution.Client.JobControl"
UnitTests.Distribution.Client.JobControl.tests
, testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"
UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
, testGroup "UnitTests.Distribution.Client.InstallPlan"
UnitTests.Distribution.Client.InstallPlan.tests
]
......
module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where
import Distribution.Text
import Data.Time
import Data.Time.Clock.POSIX
import Distribution.Client.IndexUtils.Timestamp
import Test.Tasty
import Test.Tasty.QuickCheck
tests :: [TestTree]
tests =
[ testProperty "Timestamp1" prop_timestamp1
, testProperty "Timestamp2" prop_timestamp2
, testProperty "Timestamp3" prop_timestamp3
, testProperty "Timestamp4" prop_timestamp4
, testProperty "Timestamp5" prop_timestamp5
]
-- test unixtime format parsing
prop_timestamp1 :: Int -> Bool
prop_timestamp1 t0 = Just t == simpleParse ('@':show t0)
where
t = toEnum t0 :: Timestamp
-- test display/simpleParse roundtrip
prop_timestamp2 :: Int -> Bool
prop_timestamp2 t0
| t /= nullTimestamp = simpleParse (display t) == Just t
| otherwise = display t == ""
where
t = toEnum t0 :: Timestamp
-- test display against reference impl
prop_timestamp3 :: Int -> Bool
prop_timestamp3 t0
| t /= nullTimestamp = refDisp t == display t
| otherwise = display t == ""
where
t = toEnum t0 :: Timestamp
refDisp = maybe undefined (formatTime undefined "%FT%TZ")
. timestampToUTCTime
-- test utcTimeToTimestamp/timestampToUTCTime roundtrip
prop_timestamp4 :: Int -> Bool
prop_timestamp4 t0
| t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t
| otherwise = timestampToUTCTime t == Nothing
where
t = toEnum t0 :: Timestamp
prop_timestamp5 :: Int -> Bool
prop_timestamp5 t0
| t /= nullTimestamp = timestampToUTCTime t == Just ut
| otherwise = timestampToUTCTime t == Nothing
where
t = toEnum t0 :: Timestamp
ut = posixSecondsToUTCTime (fromIntegral t0)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment