From d3e589d4a984619e43c9d043d8acd74ab6b86b57 Mon Sep 17 00:00:00 2001
From: Javier Sagredo <jasataco@gmail.com>
Date: Wed, 31 Jul 2024 17:25:34 +0200
Subject: [PATCH] Enable symlink creation on tests on Windows
---
cabal-testsuite/src/Test/Cabal/Prelude.hs | 15 ++++++++-------
1 file changed, 8 insertions(+), 7 deletions(-)
diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs
index 7a8fbf651e..50f9395d74 100644
--- a/cabal-testsuite/src/Test/Cabal/Prelude.hs
+++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs
@@ -54,6 +54,7 @@ import Control.Concurrent.Async (withAsync)
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as BSL
import Control.Monad (unless, when, void, forM_, liftM2, liftM4)
+import Control.Monad.Catch ( bracket_ )
import Control.Monad.Trans.Reader (withReaderT, runReaderT)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Crypto.Hash.SHA256 as SHA256
@@ -70,10 +71,9 @@ import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay)
import Network.Wait (waitTcpVerbose)
import System.Environment
import System.Process
+import System.IO
#ifndef mingw32_HOST_OS
-import Control.Monad.Catch ( bracket_ )
-import System.Posix.Files ( createSymbolicLink )
import System.Posix.Resource
#endif
@@ -1123,19 +1123,20 @@ withDelay m = do
Just _ -> m
-- | Create a symlink for the duration of the provided action. If the symlink
--- already exists, it is deleted. Does not work on Windows.
+-- already exists, it is deleted.
withSymlink :: FilePath -> FilePath -> TestM a -> TestM a
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) && !MIN_VERSION_directory(1,3,1)
withSymlink _oldpath _newpath _act =
- error "PackageTests.PackageTester.withSymlink: does not work on Windows!"
+ error "Test.Cabal.Prelude.withSymlink: does not work on Windows with directory <1.3.1!"
#else
withSymlink oldpath newpath0 act = do
+ liftIO $ hPutStrLn stderr $ "Symlinking " <> oldpath <> " <== " <> newpath0
env <- getTestEnv
let newpath = testCurrentDir env </> newpath0
symlinkExists <- liftIO $ doesFileExist newpath
when symlinkExists $ liftIO $ removeFile newpath
- bracket_ (liftIO $ createSymbolicLink oldpath newpath)
- (liftIO $ removeFile newpath) act
+ bracket_ (liftIO $ createFileLink oldpath newpath)
+ (liftIO $ pure ()) act
#endif
writeSourceFile :: FilePath -> String -> TestM ()
--
GitLab