Fix overly long mtime change delay calibration with HFS+.

Fixes #4230.
haskell · Feb 16, 2017 · 9752f24 · 9752f24
1 parent ca00c82
commit 9752f24
Show file tree

Hide file tree

Showing 3 changed files with 36 additions and 8 deletions.
diff --git 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
@@ -184,19 +184,33 @@ 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
             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
-    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
@@ -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