Commit c4390c84 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Implement mtime delay calibration.

parent 699a0fea
......@@ -276,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 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
......@@ -15,16 +25,25 @@ 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.Compat.Time"
UnitTests.Distribution.Client.Compat.Time.tests
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
, testGroup "UnitTests.Distribution.Client.FileMonitor" $
UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
, testGroup "Distribution.Client.GZipUtils"
UnitTests.Distribution.Client.GZipUtils.tests
, testGroup "Distribution.Client.Sandbox"
......@@ -39,13 +58,35 @@ tests = testGroup "Unit Tests"
UnitTests.Distribution.Client.UserConfig.tests
]
-- Extra options for running the test suite
extraOptions :: [OptionDescription]
extraOptions = concat [
UnitTests.Distribution.Client.Dependency.Modular.Solver.options
]
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'.
calibrateMtimeChangeDelay :: IO Int
calibrateMtimeChangeDelay = do
withTempDirectory silent "." "calibration-" $ \dir -> do
let fileName = dir </> "probe"
mtimes <- forM [1..10] $ \(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
putStrLn $ "Mtime delay calibration completed, calculated delay: "
++ (show mtimeChange) ++ " ms."
return $ min 1000000 mtimeChange
where
time :: IO () -> IO Int
time act = do
t0 <- getCurrentTime
act
t1 <- getCurrentTime
return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
......@@ -11,40 +11,37 @@ 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 =
tests :: Int -> [TestTree]
tests mtimeChange =
[ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange
, testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange
]
getModTimeTest :: Int -> Assertion
getModTimeTest mtimeChange =
withTempDirectory silent "." "getmodtime-" $ \dir -> do
let fileName = dir </> "foo"
writeFile fileName "bar"
t0 <- getModTime fileName
threadDelay mtimeDelay
threadDelay mtimeChange
writeFile fileName "baz"
t1 <- getModTime fileName
assertBool "expected different file mtimes" (t1 > t0)
getCurTimeTest :: Assertion
getCurTimeTest =
getCurTimeTest :: Int -> Assertion
getCurTimeTest mtimeChange =
withTempDirectory silent "." "getmodtime-" $ \dir -> do
let fileName = dir </> "foo"
writeFile fileName "bar"
t0 <- getModTime fileName
threadDelay mtimeDelay
threadDelay mtimeChange
t1 <- getCurTime
assertBool("expected file mtime (" ++ show t0
++ ") to be earlier than current time (" ++ show t1 ++ ")")
(t0 < t1)
threadDelay mtimeDelay
threadDelay mtimeChange
writeFile fileName "baz"
t2 <- getModTime fileName
assertBool ("expected current time (" ++ show t1
......
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options) where
module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests)
where
-- base
import Control.Monad
import Data.Maybe (isNothing)
import Data.Proxy
import Data.Typeable
import qualified Data.Version as V
import qualified Distribution.Version as V
......@@ -14,13 +12,14 @@ import qualified Distribution.Version as V
-- test-framework
import Test.Tasty as TF
import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
import Test.Tasty.Options
-- Cabal
import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..))
import Language.Haskell.Extension ( Extension(..)
, KnownExtension(..), Language(..))
-- cabal-install
import UnitTests.Distribution.Client.Dependency.Modular.DSL
import UnitTests.Options
tests :: [TF.TestTree]
tests = [
......@@ -493,22 +492,3 @@ dbBuildable2 = [
]
, Right $ exAv "B" 3 [ExAny "unknown"]
]
{-------------------------------------------------------------------------------
Test options
-------------------------------------------------------------------------------}
options :: [OptionDescription]
options = [
Option (Proxy :: Proxy OptionShowSolverLog)
]
newtype OptionShowSolverLog = OptionShowSolverLog Bool
deriving Typeable
instance IsOption OptionShowSolverLog where
defaultValue = OptionShowSolverLog False
parseValue = fmap OptionShowSolverLog . safeRead
optionName = return "show-solver-log"
optionHelp = return "Show full log from the solver"
optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)
......@@ -16,59 +16,62 @@ import Distribution.Simple.Utils (withTempDirectory)
import Distribution.Verbosity (silent)
import Distribution.Client.FileMonitor
import Distribution.Client.Compat.Time
import Test.Tasty
import Test.Tasty.HUnit
tests :: [TestTree]
tests =
[ testCase "sanity check mtimes" testFileMTimeSanity
tests :: Int -> [TestTree]
tests mtimeChange =
[ testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange
, testCase "no monitor cache" testNoMonitorCache
, testCase "corrupt monitor cache" testCorruptMonitorCache
, testCase "empty monitor" testEmptyMonitor
, testCase "missing file" testMissingFile
, testCase "change file" testChangedFile
, testCase "file mtime vs content" testChangedFileMtimeVsContent
, testCase "change file" $ testChangedFile mtimeChange
, testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange
, testCase "remove file" testRemoveFile
, testCase "non-existent file" testNonExistentFile
, testGroup "glob matches"
[ testCase "no change" testGlobNoChange
, testCase "add match" testGlobAddMatch
, testCase "add match" $ testGlobAddMatch mtimeChange
, testCase "remove match" testGlobRemoveMatch
, testCase "change match" testGlobChangeMatch
, testCase "change match" $ testGlobChangeMatch mtimeChange
, testCase "add match subdir" testGlobAddMatchSubdir
, testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange
, testCase "remove match subdir" testGlobRemoveMatchSubdir
, testCase "change match subdir" testGlobChangeMatchSubdir
, testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange
, testCase "add non-match" testGlobAddNonMatch
, testCase "add non-match" $ testGlobAddNonMatch mtimeChange
, testCase "remove non-match" testGlobRemoveNonMatch
, testCase "add non-match" testGlobAddNonMatchSubdir
, testCase "add non-match" $ testGlobAddNonMatchSubdir mtimeChange
, testCase "remove non-match" testGlobRemoveNonMatchSubdir
, testCase "invariant sorted 1" testInvariantMonitorStateGlobFiles
, testCase "invariant sorted 2" testInvariantMonitorStateGlobDirs
, testCase "invariant sorted 1" $ testInvariantMonitorStateGlobFiles
mtimeChange
, testCase "invariant sorted 2" $ testInvariantMonitorStateGlobDirs
mtimeChange
]
, testCase "value unchanged" testValueUnchanged
, testCase "value changed" testValueChanged
, testCase "value & file changed" testValueAndFileChanged
, testCase "value & file changed" $ testValueAndFileChanged mtimeChange
, testCase "value updated" testValueUpdated
]
-- we rely on file mtimes having a reasonable resolution
testFileMTimeSanity :: Assertion
testFileMTimeSanity =
testFileMTimeSanity :: Int -> Assertion
testFileMTimeSanity mtimeChange =
withTempDirectory silent "." "file-status-" $ \dir -> do
replicateM_ 10 $ do
writeFile (dir </> "a") "content"
t1 <- getModificationTime (dir </> "a")
threadDelayMTimeChange
t1 <- getModTime (dir </> "a")
threadDelay mtimeChange
writeFile (dir </> "a") "content"
t2 <- getModificationTime (dir </> "a")
t2 <- getModTime (dir </> "a")
assertBool "expected different file mtimes" (t2 > t1)
-- first run, where we don't even call updateMonitor
......@@ -130,8 +133,8 @@ testMissingFile = do
reason2 @?= MonitoredFileChanged file
testChangedFile :: Assertion
testChangedFile = do
testChangedFile :: Int -> Assertion
testChangedFile mtimeChange = do
test MonitorFile "a"
test MonitorFileHashed "a"
test MonitorFile ("dir" </> "a")
......@@ -141,14 +144,14 @@ testChangedFile = do
withFileMonitor $ \root monitor -> do
touch root file
updateMonitor root monitor [monitorKind file] () ()
threadDelayMTimeChange
threadDelay mtimeChange
write root file "different"
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged file
testChangedFileMtimeVsContent :: Assertion
testChangedFileMtimeVsContent =
testChangedFileMtimeVsContent :: Int -> Assertion
testChangedFileMtimeVsContent mtimeChange =
withFileMonitor $ \root monitor -> do
-- if we don't touch the file, it's unchanged
touch root "a"
......@@ -159,14 +162,14 @@ testChangedFileMtimeVsContent =
-- if we do touch the file, it's changed if we only consider mtime
updateMonitor root monitor [MonitorFile "a"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root "a"
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged "a"
-- but if we touch the file, it's unchanged if we consider content hash
updateMonitor root monitor [MonitorFileHashed "a"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root "a"
(res2, files2) <- expectMonitorUnchanged root monitor ()
res2 @?= ()
......@@ -174,7 +177,7 @@ testChangedFileMtimeVsContent =
-- finally if we change the content it's changed
updateMonitor root monitor [MonitorFileHashed "a"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
write root "a" "different"
reason2 <- expectMonitorChanged root monitor ()
reason2 @?= MonitoredFileChanged "a"
......@@ -243,8 +246,8 @@ testGlobNoChange =
res @?= ()
files @?= [monitorFileGlob "dir/good-*"]
testGlobAddMatch :: Assertion
testGlobAddMatch =
testGlobAddMatch :: Int -> Assertion
testGlobAddMatch mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "good-a")
updateMonitor root monitor [monitorFileGlob "dir/good-*"] () ()
......@@ -252,7 +255,7 @@ testGlobAddMatch =
res @?= ()
files @?= [monitorFileGlob "dir/good-*"]
threadDelayMTimeChange
threadDelay mtimeChange
touch root ("dir" </> "good-b")
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "good-b")
......@@ -267,13 +270,13 @@ testGlobRemoveMatch =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "good-a")
testGlobChangeMatch :: Assertion
testGlobChangeMatch =
testGlobChangeMatch :: Int -> Assertion
testGlobChangeMatch mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "good-a")
touch root ("dir" </> "good-b")
updateMonitor root monitor [monitorFileGlob "dir/good-*"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root ("dir" </> "good-b")
(res, files) <- expectMonitorUnchanged root monitor ()
res @?= ()
......@@ -283,12 +286,12 @@ testGlobChangeMatch =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "good-b")
testGlobAddMatchSubdir :: Assertion
testGlobAddMatchSubdir =
testGlobAddMatchSubdir :: Int -> Assertion
testGlobAddMatchSubdir mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "a" </> "good-a")
updateMonitor root monitor [monitorFileGlob "dir/*/good-*"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root ("dir" </> "b" </> "good-b")
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")
......@@ -303,13 +306,13 @@ testGlobRemoveMatchSubdir =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a")
testGlobChangeMatchSubdir :: Assertion
testGlobChangeMatchSubdir =
testGlobChangeMatchSubdir :: Int -> Assertion
testGlobChangeMatchSubdir mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "a" </> "good-a")
touch root ("dir" </> "b" </> "good-b")
updateMonitor root monitor [monitorFileGlob "dir/*/good-*"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root ("dir" </> "b" </> "good-b")
(res, files) <- expectMonitorUnchanged root monitor ()
res @?= ()
......@@ -319,12 +322,12 @@ testGlobChangeMatchSubdir =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")
testGlobAddNonMatch :: Assertion
testGlobAddNonMatch =
testGlobAddNonMatch :: Int -> Assertion
testGlobAddNonMatch mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "good-a")
updateMonitor root monitor [monitorFileGlob "dir/good-*"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root ("dir" </> "bad")
(res, files) <- expectMonitorUnchanged root monitor ()
res @?= ()
......@@ -341,12 +344,12 @@ testGlobRemoveNonMatch =
res @?= ()
files @?= [monitorFileGlob "dir/good-*"]
testGlobAddNonMatchSubdir :: Assertion
testGlobAddNonMatchSubdir =
testGlobAddNonMatchSubdir :: Int -> Assertion
testGlobAddNonMatchSubdir mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "a" </> "good-a")
updateMonitor root monitor [monitorFileGlob "dir/*/good-*"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
touch root ("dir" </> "b" </> "bad")
(res, files) <- expectMonitorUnchanged root monitor ()
res @?= ()
......@@ -366,15 +369,15 @@ testGlobRemoveNonMatchSubdir =
-- try and tickle a bug that happens if we don't maintain the invariant that
-- MonitorStateGlobFiles entries are sorted
testInvariantMonitorStateGlobFiles :: Assertion
testInvariantMonitorStateGlobFiles =
testInvariantMonitorStateGlobFiles :: Int -> Assertion
testInvariantMonitorStateGlobFiles mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "a")
touch root ("dir" </> "b")
touch root ("dir" </> "c")
touch root ("dir" </> "d")
updateMonitor root monitor [monitorFileGlob "dir/*"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
-- so there should be no change (since we're doing content checks)
-- but if we can get the dir entries to appear in the wrong order
-- then if the sorted invariant is not maintained then we can fool
......@@ -392,15 +395,15 @@ testInvariantMonitorStateGlobFiles =
files @?= [monitorFileGlob "dir/*"]
-- same thing for the subdirs case
testInvariantMonitorStateGlobDirs :: Assertion
testInvariantMonitorStateGlobDirs =
testInvariantMonitorStateGlobDirs :: Int -> Assertion
testInvariantMonitorStateGlobDirs mtimeChange =
withFileMonitor $ \root monitor -> do
touch root ("dir" </> "a" </> "file")
touch root ("dir" </> "b" </> "file")
touch root ("dir" </> "c" </> "file")
touch root ("dir" </> "d" </> "file")
updateMonitor root monitor [monitorFileGlob "dir/*/file"] () ()
threadDelayMTimeChange
threadDelay mtimeChange
removeDir root ("dir" </> "a")
removeDir root ("dir" </> "b")
removeDir root ("dir" </> "c")
......@@ -435,14 +438,14 @@ testValueChanged =
reason <- expectMonitorChanged root monitor 43
reason @?= MonitoredValueChanged 42
testValueAndFileChanged :: Assertion
testValueAndFileChanged =
testValueAndFileChanged :: Int -> Assertion
testValueAndFileChanged mtimeChange =
withFileMonitor $ \root monitor -> do
touch root "a"
-- we change the value and the file, and the value change is reported
updateMonitor root monitor [MonitorFile "a"] (42 :: Int) "ok"
threadDelayMTimeChange
threadDelay mtimeChange
touch root "a"
reason <- expectMonitorChanged root monitor 43
reason @?= MonitoredValueChanged 42
......@@ -457,7 +460,7 @@ testValueAndFileChanged =
-- but if a file changed too then we don't report MonitoredValueChanged
updateMonitor root monitor' [MonitorFile "a"] 42 "ok"
threadDelayMTimeChange
threadDelay mtimeChange
touch root "a"
reason3 <- expectMonitorChanged root monitor' 43
reason3 @?= MonitoredFileChanged "a"
......@@ -495,20 +498,6 @@ write (RootPath root) fname contents = do
touch :: RootPath -> FilePath -> IO ()
touch root fname = write root fname "hello"
#ifndef MIN_VERSION_unix
#define MIN_VERSION_unix(a,b,c) 0
#endif
-- Wait a moment to ensure a file mtime change
threadDelayMTimeChange :: IO ()
#if defined(mingw32_HOST_OS) || (MIN_VERSION_directory(1,2,1) && MIN_VERSION_unix(2,6,0))
-- hi-res file times
threadDelayMTimeChange = threadDelay 10000 -- 10ms
#else
-- second-res file times
threadDelayMTimeChange = threadDelay 1000000 -- 1s
#endif
remove :: RootPath -> FilePath -> IO ()
remove (RootPath root) fname = removeFile (root </> fname)
......
{-# LANGUAGE DeriveDataTypeable #-}
module UnitTests.Options ( OptionShowSolverLog(..)
, OptionMtimeChangeDelay(..)
, extraOptions )
where
import Data.Proxy
import Data.Typeable
import Test.Tasty.Options
{-------------------------------------------------------------------------------
Test options
-------------------------------------------------------------------------------}
extraOptions :: [OptionDescription]
extraOptions =
[ Option (Proxy :: Proxy OptionShowSolverLog)
, Option (Proxy :: Proxy OptionMtimeChangeDelay)
]
newtype OptionShowSolverLog = OptionShowSolverLog Bool
deriving Typeable
instance IsOption OptionShowSolverLog where
defaultValue = OptionShowSolverLog False
parseValue = fmap OptionShowSolverLog . safeRead
optionName = return "show-solver-log"
optionHelp = return "Show full log from the solver"
optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)
newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int
deriving Typeable
instance IsOption OptionMtimeChangeDelay where
defaultValue = OptionMtimeChangeDelay 0
parseValue = fmap OptionMtimeChangeDelay . safeRead
optionName = return "mtime-change-delay"
optionHelp = return $ "How long to wait before attempting to detect"
++ "file modification, in microseconds"
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