Commit 2fffe888 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #3155 from 23Skidoo/getmodtime

Improve the 'getModTime' implementation.
parents c7b6804f e62061f3
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-}
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 Distribution.Compat.Binary ( Binary )
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)
#else
import Data.Bits ((.|.), bitSize, unsafeShiftL)
#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
import Data.Bits (finiteBitSize)
#else
#define CALLCONV stdcall
import Data.Bits (bitSize)
#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
import Data.Int ( Int32 )
import Foreign ( allocaBytes, peekByteOff )
import System.IO.Error ( mkIOError, doesNotExistErrorType )
import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )
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
#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 (Binary, Bounded, Eq, Ord)
instance Show ModTime where
show (ModTime x) = show x
instance Read ModTime where
readsPrec p str = map (first ModTime) (readsPrec p str)
-- | Return modification time of given file. Works around the low clock
-- | 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 +81,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
let qwTime =
(fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)
.|. (fromIntegral (dwLow :: DWORD))
#endif
return $! ModTime (qwTime :: Word64)
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh)
.|. (fromIntegral dwLow)
#define CALLCONV stdcall
#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
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 +162,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'.
......@@ -40,11 +40,6 @@ import Data.Traversable (traverse)
#endif
import qualified Data.Hashable as Hashable
import Data.List (sort)
#if MIN_VERSION_directory(1,2,0)
import Data.Time (UTCTime(..), Day(..))
#else
import System.Time (ClockTime(..))
#endif
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
......@@ -61,6 +56,7 @@ import Distribution.Compat.ReadP ((<++))
import qualified Distribution.Compat.ReadP as ReadP
import qualified Text.PrettyPrint as Disp
import Distribution.Client.Compat.Time
import Distribution.Client.Glob
import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
......@@ -153,11 +149,6 @@ data MonitorStateFileSet
deriving Show
type Hash = Int
#if MIN_VERSION_directory(1,2,0)
type ModTime = UTCTime
#else
type ModTime = ClockTime
#endif
-- | The state necessary to determine whether a monitored file has changed.
--
......@@ -676,7 +667,7 @@ buildMonitorStateFileSet root =
go !singlePaths !globPaths (MonitorFile path : monitors) = do
let file = root </> path
monitorState <- handleDoesNotExist MonitorStateFileGone $
MonitorStateFile <$> getModificationTime file
MonitorStateFile <$> getModTime file
let singlePaths' = Map.insert path monitorState singlePaths
go singlePaths' globPaths monitors
......@@ -684,7 +675,7 @@ buildMonitorStateFileSet root =
let file = root </> path
monitorState <- handleDoesNotExist MonitorStateFileHashGone $
MonitorStateFileHashed
<$> getModificationTime file
<$> getModTime file
<*> readFileHash file
let singlePaths' = Map.insert path monitorState singlePaths
go singlePaths' globPaths monitors
......@@ -712,7 +703,7 @@ buildMonitorStateGlob :: FilePath -- ^ the root directory
-> IO MonitorStateGlob
buildMonitorStateGlob root dir globPath = do
dirEntries <- getDirectoryContents (root </> dir)
dirMTime <- getModificationTime (root </> dir)
dirMTime <- getModTime (root </> dir)
case globPath of
GlobDir glob globPath' -> do
subdirs <- filterM (\subdir -> doesDirectoryExist
......@@ -730,7 +721,7 @@ buildMonitorStateGlob root dir globPath = do
filesStates <-
forM (sort files) $ \file -> do
let path = root </> dir </> file
mtime <- getModificationTime path
mtime <- getModTime path
hash <- readFileHash path
return (file, mtime, hash)
return $! MonitorStateGlobFiles glob dirMTime filesStates
......@@ -789,7 +780,7 @@ checkModificationTimeUnchanged :: FilePath -> FilePath
-> ModTime -> IO Bool
checkModificationTimeUnchanged root file mtime =
handleDoesNotExist False $ do
mtime' <- getModificationTime (root </> file)
mtime' <- getModTime (root </> file)
return (mtime == mtime')
-- | Returns @True@ if, inside the @root@ directory, @file@ has the
......@@ -798,7 +789,7 @@ checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath
-> ModTime -> Hash -> IO Bool
checkFileModificationTimeAndHashUnchanged root file mtime chash =
handleDoesNotExist False $ do
mtime' <- getModificationTime (root </> file)
mtime' <- getModTime (root </> file)
if mtime == mtime'
then return True
else do
......@@ -816,7 +807,7 @@ readFileHash file =
checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime)
checkDirectoryModificationTime dir mtime =
handleDoesNotExist Nothing $ do
mtime' <- getModificationTime dir
mtime' <- getModTime dir
if mtime == mtime'
then return Nothing
else return (Just mtime')
......@@ -843,27 +834,6 @@ instance Text FilePathGlob where
return (GlobDir glob globs)
asFile glob = return (GlobFile glob)
#if MIN_VERSION_directory(1,2,0)
instance Binary UTCTime where
put (UTCTime (ModifiedJulianDay day) tod) = do
put day
put (toRational tod)
get = do
day <- get
tod <- get
return $! UTCTime (ModifiedJulianDay day)
(fromRational tod)
#else
instance Binary ClockTime where
put (TOD sec subsec) = do
put sec
put subsec
get = do
!sec <- get
!subsec <- get
return (TOD sec subsec)
#endif
instance Binary MonitorStateFileSet where
put (MonitorStateFileSet singlePaths globPaths) = do
put (1 :: Int) -- version
......
......@@ -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
......
......@@ -115,7 +115,9 @@ executable cabal
main-is: Main.hs
ghc-options: -Wall -fwarn-tabs
if impl(ghc >= 8.0)
ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
ghc-options: -Wcompat
-Wnoncanonical-monad-instances
-Wnoncanonical-monadfail-instances
other-modules:
Distribution.Client.BuildReports.Anonymous
......@@ -274,6 +276,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Client.Sandbox
UnitTests.Distribution.Client.Tar
UnitTests.Distribution.Client.UserConfig
UnitTests.Options
build-depends:
base,
array,
......
{-# LANGUAGE ScopedTypeVariables #-}
module Main
where
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 Control.Monad
import Data.Time.Clock
import System.FilePath
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Client.Compat.Time
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"
import UnitTests.Options
tests :: Int -> TestTree
tests mtimeChangeCalibrated =
askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->
let mtimeChange = if mtimeChangeProvided /= 0
then mtimeChangeProvided
else mtimeChangeCalibrated
in
testGroup "Unit Tests"
[ testGroup "UnitTests.Distribution.Client.Compat.Time" $
UnitTests.Distribution.Client.Compat.Time.tests mtimeChange
, testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"
UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
, testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
, testGroup "UnitTests.Distribution.Client.FileMonitor" $
UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
, testGroup "Distribution.Client.GZipUtils"
UnitTests.Distribution.Client.GZipUtils.tests
, testGroup "Distribution.Client.Sandbox"
UnitTests.Distribution.Client.Sandbox.tests
,testGroup "Distribution.Client.Tar"
, testGroup "Distribution.Client.Sandbox.Timestamp"
UnitTests.Distribution.Client.Sandbox.Timestamp.tests
, testGroup "Distribution.Client.Tar"
UnitTests.Distribution.Client.Tar.tests
,testGroup "Distribution.Client.Targets"
, 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"
UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
,testGroup "UnitTests.Distribution.Client.FileMonitor"
UnitTests.Distribution.Client.FileMonitor.tests
]
-- Extra options for running the test suite
extraOptions :: [OptionDescription]
extraOptions = concat [
UnitTests.Distribution.Client.Dependency.Modular.Solver.options
, testGroup "UnitTests.Distribution.Client.UserConfig"
UnitTests.Distribution.Client.UserConfig.tests
]
main :: IO ()
main = defaultMainWithIngredients
main = do
mtimeChangeDelay <- calibrateMtimeChangeDelay
defaultMainWithIngredients
(includingOptions extraOptions : defaultIngredients)
tests
(tests mtimeChangeDelay)
-- Based on code written by Neill Mitchell for Shake. See
-- 'sleepFileTimeCalibrate' in 'Test.Type'. The returned delay is never smaller
-- than 10 ms, but never larger than 1 second.
calibrateMtimeChangeDelay :: IO Int
calibrateMtimeChangeDelay = do
withTempDirectory silent "." "calibration-" $ \dir -> do
let fileName = dir </> "probe"
mtimes <- forM [1..25] $ \(i::Int) -> time $ do
writeFile fileName $ show i
t0 <- getModTime fileName
let spin j = do
writeFile fileName $ show (i,j)
t1 <- getModTime fileName
unless (t0 < t1) (spin $ j + 1)
spin (0::Int)
let mtimeChange = maximum mtimes
mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2
notice normal $ "File modification time resolution calibration completed, "
++ "maximum delay observed: "
++ (show . toMillis $ mtimeChange ) ++ " ms. "
++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')
++ " for test runs."
return mtimeChange'
where
toMillis :: Int -> Double