Commit 0e381dac authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Make withTemp{File,Directory} more robust.

The finaliser used to fail when the user action deleted the file. See
https://github.com/haskell/cabal/issues/3140#issuecomment-183463437.
parent 9330d82e
......@@ -189,7 +189,8 @@ library
ghc-options: -Wall -fno-ignore-asserts -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
exposed-modules:
Distribution.Compat.CreatePipe
......@@ -295,17 +296,19 @@ test-suite unit-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
other-modules:
Test.Laws
Test.QuickCheck.Utils
UnitTests.Distribution.Compat.CreatePipe
UnitTests.Distribution.Compat.ReadP
UnitTests.Distribution.Simple.Program.Internal
UnitTests.Distribution.Utils.NubList
UnitTests.Distribution.Simple.Utils
UnitTests.Distribution.System
UnitTests.Distribution.Utils.NubList
UnitTests.Distribution.Version
Test.Laws
Test.QuickCheck.Utils
main-is: UnitTests.hs
build-depends:
base,
directory,
tasty,
tasty-hunit,
tasty-quickcheck,
......
......@@ -26,6 +26,9 @@ module Distribution.Simple.Utils (
debugNoWrap, chattyTry,
printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
-- * exceptions
handleDoesNotExist,
-- * running programs
rawSystemExit,
rawSystemExitCode,
......@@ -349,6 +352,14 @@ chattyTry desc action =
catchIO action $ \exception ->
putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
-- | Run an IO computation, returning @e@ if it raises a "file
-- does not exist" error.
handleDoesNotExist :: a -> IO a -> IO a
handleDoesNotExist e =
Exception.handleJust
(\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
(\_ -> return e)
-- -----------------------------------------------------------------------------
-- Helper functions
......@@ -1085,7 +1096,8 @@ withTempFileEx opts tmpDir template action =
Exception.bracket
(openTempFile tmpDir template)
(\(name, handle) -> do hClose handle
unless (optKeepTempFiles opts) $ removeFile name)
unless (optKeepTempFiles opts) $
handleDoesNotExist () . removeFile $ name)
(uncurry action)
-- | Create and use a temporary directory.
......@@ -1111,7 +1123,8 @@ withTempDirectoryEx :: Verbosity
withTempDirectoryEx _verbosity opts targetDir template =
Exception.bracket
(createTempDirectory targetDir template)
(unless (optKeepTempFiles opts) . removeDirectoryRecursive)
(unless (optKeepTempFiles opts)
. handleDoesNotExist () . removeDirectoryRecursive)
-----------------------------------
-- Safely reading and writing files
......
......@@ -7,24 +7,27 @@ import Test.Tasty
import qualified UnitTests.Distribution.Compat.CreatePipe
import qualified UnitTests.Distribution.Compat.ReadP
import qualified UnitTests.Distribution.Simple.Program.Internal
import qualified UnitTests.Distribution.Utils.NubList
import qualified UnitTests.Distribution.Simple.Utils
import qualified UnitTests.Distribution.System
import qualified UnitTests.Distribution.Utils.NubList
import qualified UnitTests.Distribution.Version (versionTests)
tests :: TestTree
tests = testGroup "Unit Tests" $
[ testGroup "Distribution.Compat.ReadP"
UnitTests.Distribution.Compat.ReadP.tests
, testGroup "Distribution.Compat.CreatePipe"
[ testGroup "Distribution.Compat.CreatePipe"
UnitTests.Distribution.Compat.CreatePipe.tests
, testGroup "Distribution.Compat.ReadP"
UnitTests.Distribution.Compat.ReadP.tests
, testGroup "Distribution.Simple.Program.Internal"
UnitTests.Distribution.Simple.Program.Internal.tests
, testGroup "Distribution.Simple.Utils"
UnitTests.Distribution.Simple.Utils.tests
, testGroup "Distribution.Utils.NubList"
UnitTests.Distribution.Utils.NubList.tests
, testGroup "Distribution.System"
UnitTests.Distribution.System.tests
, UnitTests.Distribution.Version.versionTests
-- , UnitTests.Distribution.Version.parseTests
, testGroup "Distribution.Version"
UnitTests.Distribution.Version.versionTests
]
main :: IO ()
......
module UnitTests.Distribution.Simple.Utils
( tests
) where
import Distribution.Simple.Utils
import Distribution.Verbosity
import System.Directory (getTemporaryDirectory, removeDirectoryRecursive
,removeFile)
import System.IO (hClose)
import Test.Tasty
import Test.Tasty.HUnit
withTempFileTest :: Assertion
withTempFileTest = do
tempDir <- getTemporaryDirectory
withTempFile tempDir ".foo" $ \fileName handle -> do
hClose handle
removeFile fileName
withTempDirTest :: Assertion
withTempDirTest = do
tempDir <- getTemporaryDirectory
withTempDirectory normal tempDir "foo" $ \dirPath -> do
removeDirectoryRecursive dirPath
tests :: [TestTree]
tests =
[ testCase "withTempFile can handle removed files" $
withTempFileTest
, testCase "withTempDirectory can handle removed directories" $
withTempDirTest
]
......@@ -10,7 +10,7 @@ import Distribution.Text
import Text.PrettyPrint as Disp (text, render, parens, hcat
,punctuate, int, char, (<>), (<+>))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.QuickCheck.Utils
import qualified Test.Laws as Laws
......@@ -20,9 +20,8 @@ import Data.Maybe (isJust, fromJust)
import Data.List (sort, sortBy, nub)
import Data.Ord (comparing)
versionTests :: TestTree
versionTests :: [TestTree]
versionTests =
testGroup "Distribution.Version" $
zipWith (\n p -> testProperty ("Range Property " ++ show n) p) [1::Int ..]
-- properties to validate the test framework
[ property prop_nonNull
......@@ -85,9 +84,8 @@ versionTests =
, property prop_invertVersionIntervalsTwice
]
-- parseTests :: TestTree
-- parseTests :: [TestTree]
-- parseTests =
-- testGroup "Distribution.Version" $
-- zipWith (\n p -> testProperty ("Parse Property " ++ show n) p) [1::Int ..]
-- -- parsing and pretty printing
-- [ -- property prop_parse_disp1 --FIXME: actually wrong
......
......@@ -62,7 +62,7 @@ import qualified Distribution.Compat.ReadP as ReadP
import qualified Text.PrettyPrint as Disp
import Distribution.Client.Glob
import Distribution.Simple.Utils (writeFileAtomic)
import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
import System.FilePath
......@@ -822,14 +822,6 @@ checkDirectoryModificationTime dir mtime =
then return Nothing
else return (Just mtime')
-- | Run an IO computation, returning @e@ if it raises a "file
-- does not exist" error.
handleDoesNotExist :: a -> IO a -> IO a
handleDoesNotExist e =
handleJust
(\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
(\_ -> return e)
-- | Run an IO computation, returning @e@ if there is an 'error'
-- call. ('ErrorCall')
handleErrorCall :: a -> IO a -> IO a
......
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