Commit 699a0fea authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Improve the 'getModTime' implementation.

Two changes:

  * 'getModTime' now uses 'modificationTimeHiRes' instead of 'modificationTime'
    on Unix when the former is available.

  * 'ModTime' is now represented as a 64-bit unsigned integer in Windows UTC
    format (that is, 100 ns resolution and day zero is 1601-01-01) on all
    platforms. Previously we used POSIX seconds, which was wrong (low
    resolution). Sandbox timestamp files in old format are now up-converted on
    the fly.

Fixes #3132.
parent 28411eed
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Distribution.Client.Compat.Time
(EpochTime, getModTime, getFileAge, getCurTime)
( ModTime(..) -- Needed for testing
, getModTime, getFileAge, getCurTime
, posixSecondsToModTime )
where
import Data.Int (Int64)
import System.Directory (getModificationTime)
import Control.Arrow ( first )
import Data.Int ( Int64 )
import Data.Word ( Word64 )
import System.Directory ( getModificationTime )
import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )
#if MIN_VERSION_directory(1,2,0)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength)
import Data.Time (getCurrentTime, diffUTCTime)
import Data.Time.Clock.POSIX ( posixDayLength )
import Data.Time ( diffUTCTime, getCurrentTime )
#else
import System.Time (ClockTime(..), getClockTime
,diffClockTimes, normalizeTimeDiff, tdDay, tdHour)
import System.Time ( getClockTime, diffClockTimes
, normalizeTimeDiff, tdDay, tdHour )
#endif
#if defined mingw32_HOST_OS
import Data.Bits ((.|.), unsafeShiftL)
#if MIN_VERSION_base(4,7,0)
import Data.Bits ((.|.), finiteBitSize, unsafeShiftL)
import Data.Bits (finiteBitSize)
#else
import Data.Bits ((.|.), bitSize, unsafeShiftL)
import Data.Bits (bitSize)
#endif
import Data.Int (Int32)
import Data.Word (Word64)
import Foreign (allocaBytes, peekByteOff)
import System.IO.Error (mkIOError, doesNotExistErrorType)
import System.Win32.Types (BOOL, DWORD, LPCTSTR, LPVOID, withTString)
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif
foreign import CALLCONV "windows.h GetFileAttributesExW"
c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL
getFileAttributesEx :: String -> LPVOID -> IO BOOL
getFileAttributesEx path lpFileInformation =
withTString path $ \c_path ->
c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation
getFileExInfoStandard :: Int32
getFileExInfoStandard = 0
import Data.Int ( Int32 )
import Foreign ( allocaBytes, peekByteOff )
import System.IO.Error ( mkIOError, doesNotExistErrorType )
import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )
size_WIN32_FILE_ATTRIBUTE_DATA :: Int
size_WIN32_FILE_ATTRIBUTE_DATA = 36
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20
#else
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24
import System.Posix.Files ( FileStatus, getFileStatus )
#if MIN_VERSION_unix(2,6,0)
import System.Posix.Files ( modificationTimeHiRes )
#else
import Foreign.C.Types (CTime(..))
import System.Posix.Files (getFileStatus, modificationTime)
import System.Posix.Files ( modificationTime )
#endif
#endif
-- | The number of seconds since the UNIX epoch.
type EpochTime = Int64
-- | An opaque type representing a file's modification time, represented
-- internally as a 64-bit unsigned integer in the Windows UTC format.
newtype ModTime = ModTime Word64
deriving (Bounded, Eq, Ord)
instance Show ModTime where
show (ModTime x) = show x
-- | Return modification time of given file. Works around the low clock
instance Read ModTime where
readsPrec p str = map (first ModTime) (readsPrec p str)
-- | Return modification time of the given file. Works around the low clock
-- resolution problem that 'getModificationTime' has on GHC < 7.8.
--
-- This is a modified version of the code originally written for OpenShake by
-- Neil Mitchell. See module Development.Shake.FileTime.
getModTime :: FilePath -> IO EpochTime
-- This is a modified version of the code originally written for Shake by Neil
-- Mitchell. See module Development.Shake.FileInfo.
getModTime :: FilePath -> IO ModTime
#if defined mingw32_HOST_OS
......@@ -86,39 +79,74 @@ getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime
dwHigh <- peekByteOff info
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime
return $! windowsTimeToPOSIXSeconds dwLow dwHigh
where
windowsTimeToPOSIXSeconds :: DWORD -> DWORD -> EpochTime
windowsTimeToPOSIXSeconds dwLow dwHigh =
let wINDOWS_TICK = 10000000
sEC_TO_UNIX_EPOCH = 11644473600
#if MIN_VERSION_base(4,7,0)
qwTime = (fromIntegral dwHigh `unsafeShiftL` finiteBitSize dwHigh)
.|. (fromIntegral dwLow)
let qwTime =
(fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)
.|. (fromIntegral (dwLow :: DWORD))
#else
qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh)
.|. (fromIntegral dwLow)
let qwTime =
(fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)
.|. (fromIntegral (dwLow :: DWORD))
#endif
res = ((qwTime :: Word64) `div` wINDOWS_TICK)
- sEC_TO_UNIX_EPOCH
-- TODO: What if the result is not representable as POSIX seconds?
-- Probably fine to return garbage.
in fromIntegral res
return $! ModTime (qwTime :: Word64)
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif
foreign import CALLCONV "windows.h GetFileAttributesExW"
c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL
getFileAttributesEx :: String -> LPVOID -> IO BOOL
getFileAttributesEx path lpFileInformation =
withTString path $ \c_path ->
c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation
getFileExInfoStandard :: Int32
getFileExInfoStandard = 0
size_WIN32_FILE_ATTRIBUTE_DATA :: Int
size_WIN32_FILE_ATTRIBUTE_DATA = 36
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 20
#else
-- Directly against the unix library.
getModTime path = do
-- CTime is Int32 in base 4.5, Int64 in base >= 4.6, and an abstract type in
-- base < 4.5.
t <- fmap modificationTime $ getFileStatus path
#if MIN_VERSION_base(4,5,0)
let CTime i = t
return (fromIntegral i)
st <- getFileStatus path
return $! (extractFileTime st)
extractFileTime :: FileStatus -> ModTime
#if MIN_VERSION_unix(2,6,0)
extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)
#else
return (read . show $ t)
extractFileTime x = posixSecondsToModTime $ fromIntegral $ fromEnum $
modificationTime x
#endif
#endif
windowsTick, secToUnixEpoch :: Word64
windowsTick = 10000000
secToUnixEpoch = 11644473600
-- | Convert POSIX seconds to ModTime.
posixSecondsToModTime :: Int64 -> ModTime
posixSecondsToModTime s =
ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick
-- | Convert 'POSIXTime' to 'ModTime'.
posixTimeToModTime :: POSIXTime -> ModTime
posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision
+ (secToUnixEpoch * windowsTick)
-- | Return age of given file in days.
getFileAge :: FilePath -> IO Double
getFileAge file = do
......@@ -132,11 +160,6 @@ getFileAge file = do
return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0
#endif
getCurTime :: IO EpochTime
getCurTime = do
#if MIN_VERSION_directory(1,2,0)
(truncate . utcTimeToPOSIXSeconds) `fmap` getCurrentTime
#else
(TOD s _) <- getClockTime
return $! fromIntegral s
#endif
-- | Return the current time as 'ModTime'.
getCurTime :: IO ModTime
getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
......@@ -14,6 +14,11 @@ module Distribution.Client.Sandbox.Timestamp (
maybeAddCompilerTimestampRecord,
listModifiedDeps,
removeTimestamps,
-- * For testing
TimestampFileRecord,
readTimestampFile,
writeTimestampFile
) where
import Control.Exception (IOException)
......@@ -50,12 +55,13 @@ import Distribution.Client.Utils
(inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc)
import Distribution.Compat.Exception (catchIO)
import Distribution.Client.Compat.Time (EpochTime, getCurTime,
getModTime)
import Distribution.Client.Compat.Time (ModTime, getCurTime,
getModTime,
posixSecondsToModTime)
-- | Timestamp of an add-source dependency.
type AddSourceTimestamp = (FilePath, EpochTime)
type AddSourceTimestamp = (FilePath, ModTime)
-- | Timestamp file record - a string identifying the compiler & platform plus a
-- list of add-source timestamps.
type TimestampFileRecord = (String, [AddSourceTimestamp])
......@@ -79,15 +85,37 @@ readTimestampFile :: FilePath -> IO [TimestampFileRecord]
readTimestampFile timestampFile = do
timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"
case reads timestampString of
[(timestamps, s)] | all isSpace s -> return timestamps
_ ->
die $ "The timestamps file is corrupted. "
++ "Please delete & recreate the sandbox."
[(version, s)]
| version == (2::Int) ->
case reads s of
[(timestamps, s')] | all isSpace s' -> return timestamps
_ -> dieCorrupted
| otherwise -> dieWrongFormat
-- Old format (timestamps are POSIX seconds). Convert to new format.
[] ->
case reads timestampString of
[(timestamps, s)] | all isSpace s -> do
let timestamps' = map (\(i, ts) ->
(i, map (\(p, t) ->
(p, posixSecondsToModTime t)) ts))
timestamps
writeTimestampFile timestampFile timestamps'
return timestamps'
_ -> dieCorrupted
_ -> dieCorrupted
where
dieWrongFormat = die $ wrongFormat ++ deleteAndRecreate
dieCorrupted = die $ corrupted ++ deleteAndRecreate
wrongFormat = "The timestamps file is in the wrong format."
corrupted = "The timestamps file is corrupted."
deleteAndRecreate = " Please delete and recreate the sandbox."
-- | Write the timestamp file, atomically.
writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()
writeTimestampFile timestampFile timestamps = do
writeFile timestampTmpFile (show timestamps)
writeFile timestampTmpFile "2\n" -- version
appendFile timestampTmpFile (show timestamps ++ "\n")
renameFile timestampTmpFile timestampFile
where
timestampTmpFile = timestampFile <.> "tmp"
......@@ -105,7 +133,7 @@ withTimestampFile sandboxDir process = do
-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list
-- for each path. If a timestamp for a given path already exists in the list,
-- update it.
addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath]
addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath]
-> [AddSourceTimestamp]
addTimestamps initial timestamps newPaths =
[ (p, initial) | p <- newPaths ] ++ oldTimestamps
......@@ -116,7 +144,7 @@ addTimestamps initial timestamps newPaths =
-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
-- we've reinstalled and a new timestamp value, update the timestamp value for
-- the deps in the list. If there are new paths in the list, ignore them.
updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> EpochTime
updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime
-> [AddSourceTimestamp]
updateTimestamps timestamps pathsToUpdate newTimestamp =
foldr updateTimestamp [] timestamps
......@@ -156,7 +184,7 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
-- build tree refs to the timestamps file (for all compilers).
withAddTimestamps :: FilePath -> IO [FilePath] -> IO ()
withAddTimestamps sandboxDir act = do
let initialTimestamp = 0
let initialTimestamp = minBound
withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act
-- | Given a list of build tree refs, remove those
......@@ -192,7 +220,7 @@ withActionOnAllTimestamps f sandboxDir act =
-- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result
-- and then updates the timestamp file record. The IO action is run only once.
withActionOnCompilerTimestamps :: ([AddSourceTimestamp]
-> [FilePath] -> EpochTime
-> [FilePath] -> ModTime
-> [AddSourceTimestamp])
-> FilePath
-> CompilerId
......@@ -250,7 +278,7 @@ allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do
return ret
-- | Has this dependency been modified since we have last looked at it?
isDepModified :: Verbosity -> EpochTime -> AddSourceTimestamp -> IO Bool
isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool
isDepModified verbosity now (packageDir, timestamp) = do
debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)
depSources <- allPackageSourceFiles verbosity packageDir
......
......@@ -4,33 +4,39 @@ module Main
import Test.Tasty
import Test.Tasty.Options
import qualified UnitTests.Distribution.Client.Sandbox
import qualified UnitTests.Distribution.Client.UserConfig
import qualified UnitTests.Distribution.Client.Tar
import qualified UnitTests.Distribution.Client.Targets
import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.Compat.Time
import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver
import qualified UnitTests.Distribution.Client.FileMonitor
import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.Sandbox
import qualified UnitTests.Distribution.Client.Sandbox.Timestamp
import qualified UnitTests.Distribution.Client.Tar
import qualified UnitTests.Distribution.Client.Targets
import qualified UnitTests.Distribution.Client.UserConfig
tests :: TestTree
tests = testGroup "Unit Tests" [
testGroup "UnitTests.Distribution.Client.UserConfig"
UnitTests.Distribution.Client.UserConfig.tests
,testGroup "Distribution.Client.Sandbox"
UnitTests.Distribution.Client.Sandbox.tests
,testGroup "Distribution.Client.Tar"
UnitTests.Distribution.Client.Tar.tests
,testGroup "Distribution.Client.Targets"
UnitTests.Distribution.Client.Targets.tests
,testGroup "Distribution.Client.GZipUtils"
UnitTests.Distribution.Client.GZipUtils.tests
,testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"
tests = testGroup "Unit Tests"
[ testGroup "UnitTests.Distribution.Client.Compat.Time"
UnitTests.Distribution.Client.Compat.Time.tests
, testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"
UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
, testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
,testGroup "UnitTests.Distribution.Client.FileMonitor"
, testGroup "UnitTests.Distribution.Client.FileMonitor"
UnitTests.Distribution.Client.FileMonitor.tests
, testGroup "Distribution.Client.GZipUtils"
UnitTests.Distribution.Client.GZipUtils.tests
, testGroup "Distribution.Client.Sandbox"
UnitTests.Distribution.Client.Sandbox.tests
, testGroup "Distribution.Client.Sandbox.Timestamp"
UnitTests.Distribution.Client.Sandbox.Timestamp.tests
, testGroup "Distribution.Client.Tar"
UnitTests.Distribution.Client.Tar.tests
, testGroup "Distribution.Client.Targets"
UnitTests.Distribution.Client.Targets.tests
, testGroup "UnitTests.Distribution.Client.UserConfig"
UnitTests.Distribution.Client.UserConfig.tests
]
-- Extra options for running the test suite
......
module UnitTests.Distribution.Client.Compat.Time (tests) where
import Control.Concurrent (threadDelay)
import System.FilePath
import Distribution.Simple.Utils (withTempDirectory)
import Distribution.Verbosity
import Distribution.Client.Compat.Time
import Test.Tasty
import Test.Tasty.HUnit
-- TODO: Calibrate, like Shake's test suite does.
mtimeDelay :: Int
mtimeDelay = 500000 -- 0.5 s
tests :: [TestTree]
tests =
[ testCase "getModTime has sub-second resolution" getModTimeTest
, testCase "getCurTime works as expected" getCurTimeTest ]
getModTimeTest :: Assertion
getModTimeTest =
withTempDirectory silent "." "getmodtime-" $ \dir -> do
let fileName = dir </> "foo"
writeFile fileName "bar"
t0 <- getModTime fileName
threadDelay mtimeDelay
writeFile fileName "baz"
t1 <- getModTime fileName
assertBool "expected different file mtimes" (t1 > t0)
getCurTimeTest :: Assertion
getCurTimeTest =
withTempDirectory silent "." "getmodtime-" $ \dir -> do
let fileName = dir </> "foo"
writeFile fileName "bar"
t0 <- getModTime fileName
threadDelay mtimeDelay
t1 <- getCurTime
assertBool("expected file mtime (" ++ show t0
++ ") to be earlier than current time (" ++ show t1 ++ ")")
(t0 < t1)
threadDelay mtimeDelay
writeFile fileName "baz"
t2 <- getModTime fileName
assertBool ("expected current time (" ++ show t1
++ ") to be earlier than file mtime (" ++ show t2 ++ ")")
(t1 < t2)
module UnitTests.Distribution.Client.Sandbox.Timestamp (tests) where
import System.FilePath
import Distribution.Simple.Utils (withTempDirectory)
import Distribution.Verbosity
import Distribution.Client.Compat.Time
import Distribution.Client.Sandbox.Timestamp
import Test.Tasty
import Test.Tasty.HUnit
tests :: [TestTree]
tests =
[ testCase "timestamp record version 1 can be read" timestampReadTest_v1
, testCase "timestamp record version 2 can be read" timestampReadTest_v2
, testCase "written timestamp record can be read" timestampReadWriteTest ]
timestampRecord_v1 :: String
timestampRecord_v1 =
"[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" ++
",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]\n"
timestampRecord_v2 :: String
timestampRecord_v2 =
"2\n" ++
"[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" ++
",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]"
timestampReadTest_v1 :: Assertion
timestampReadTest_v1 =
timestampReadTest timestampRecord_v1 $
map (\(i, ts) ->
(i, map (\(p, ModTime t) ->
(p, posixSecondsToModTime . fromIntegral $ t)) ts))
timestampRecord
timestampReadTest_v2 :: Assertion
timestampReadTest_v2 = timestampReadTest timestampRecord_v2 timestampRecord
timestampReadTest :: FilePath -> [TimestampFileRecord] -> Assertion
timestampReadTest fileContent expected =
withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do
let fileName = dir </> "timestamp-record"
writeFile fileName fileContent
tRec <- readTimestampFile fileName
assertEqual "expected timestamp records to be equal"
expected tRec
timestampRecord :: [TimestampFileRecord]
timestampRecord =
[("i386-linux-ghc-8.0.0.20160204",[("/foo/bar/Baz",ModTime 1455350946)])
,("i386-linux-ghc-7.10.3",[("/foo/bar/Baz",ModTime 1455484719)])]
timestampReadWriteTest :: Assertion
timestampReadWriteTest =
withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do
let fileName = dir </> "timestamp-record"
writeTimestampFile fileName timestampRecord
tRec <- readTimestampFile fileName
assertEqual "expected timestamp records to be equal"
timestampRecord tRec
Supports Markdown
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