diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index e7dd4fb4825..d12e7163f7b 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -355,6 +355,7 @@ test-suite unit-tests containers, directory, filepath, + time, tasty, tasty-hunit, tasty-quickcheck, diff --git a/Cabal/Distribution/Compat/Time.hs b/Cabal/Distribution/Compat/Time.hs index db359aca426..2a6a8ea0c41 100644 --- a/Cabal/Distribution/Compat/Time.hs +++ b/Cabal/Distribution/Compat/Time.hs @@ -184,8 +184,25 @@ getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. calibrateMtimeChangeDelay :: IO (Int, Int) calibrateMtimeChangeDelay = withTempDirectory silent "." "calibration-" $ \dir -> do - let fileName = dir "probe" - mtimes <- for [1..25] $ \(i::Int) -> time $ do + mtimes <- sampleMtimes (dir "probe") + let mtimeChange = maximum mtimes + mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 + return (mtimeChange, mtimeChange') + where + + sampleMtimes :: FilePath -> IO [Int] + sampleMtimes fileName = do + mtime0 <- sampleMtime 1 fileName + -- Some filesystems (e.g. HFS+ on Mac) store mtimes with 1 + -- second resolution. Bail out directly instead of spinning in + -- that case. + if (mtime0 >= 1000000) || (1000000 - mtime0 <= 10000) + then return [mtime0] + else do mtimes <- for [2..25] $ \(i::Int) -> sampleMtime i fileName + return (mtime0:mtimes) + + sampleMtime :: Int -> FilePath -> IO Int + sampleMtime i fileName = time $ do writeFile fileName $ show i t0 <- getModTime fileName let spin j = do @@ -193,10 +210,7 @@ calibrateMtimeChangeDelay = t1 <- getModTime fileName unless (t0 < t1) (spin $ j + 1) spin (0::Int) - let mtimeChange = maximum mtimes - mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 - return (mtimeChange, mtimeChange') - where + time :: IO () -> IO Int time act = do t0 <- getCurrentTime diff --git a/Cabal/tests/UnitTests/Distribution/Compat/Time.hs b/Cabal/tests/UnitTests/Distribution/Compat/Time.hs index db656db0be0..de780457063 100644 --- a/Cabal/tests/UnitTests/Distribution/Compat/Time.hs +++ b/Cabal/tests/UnitTests/Distribution/Compat/Time.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE BangPatterns #-} module UnitTests.Distribution.Compat.Time (tests) where import Control.Concurrent (threadDelay) +import Data.Time (diffUTCTime, getCurrentTime) import System.FilePath import Distribution.Simple.Utils (withTempDirectory) @@ -13,8 +15,10 @@ import Test.Tasty.HUnit tests :: Int -> [TestTree] tests mtimeChange = - [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange - , testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange + [ testCase "getModTime has expected resolution" $ getModTimeTest mtimeChange + , testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange + , testCase "calibrateMtimeChangeDelay is reasonably fast" + $ calibrateMtimeChangeDelayTest ] getModTimeTest :: Int -> Assertion @@ -47,3 +51,12 @@ getCurTimeTest mtimeChange = assertBool ("expected current time (" ++ show t1 ++ ") to be earlier than file mtime (" ++ show t2 ++ ")") (t1 < t2) + +-- See #4230. +calibrateMtimeChangeDelayTest :: Assertion +calibrateMtimeChangeDelayTest = do + t0 <- getCurrentTime + (!_maxDelay, !_recDelay) <- calibrateMtimeChangeDelay + t1 <- getCurrentTime + assertBool "expected calibrateMtimeChangeDelay to take less than 2 seconds" $ + (t1 `diffUTCTime` t0) < 2