diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 1be748e..6cabc69 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -289,6 +289,7 @@ fi eghcup upgrade eghcup upgrade -f +# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke' mkdir no_nuke/ mkdir no_nuke/bar echo 'foo' > no_nuke/file diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 05b23e1..505ea2b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1809,7 +1809,7 @@ rmGHCVer ver = do Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack dir forM_ files (lift . recycleFile . (\f -> dir dropDrive f)) - removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) dir + removeEmptyDirsRecursive dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir f <- recordedInstallationFile GHC ver lift $ recycleFile f @@ -1893,7 +1893,7 @@ rmHLSVer ver = do Just files -> do lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir forM_ files (lift . recycleFile . (\f -> hlsDir dropDrive f)) - removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) hlsDir + removeEmptyDirsRecursive hlsDir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir f <- recordedInstallationFile HLS (mkTVer ver) lift $ recycleFile f @@ -2049,7 +2049,7 @@ rmGhcupDirs = do logInfo $ "removing " <> T.pack (fromGHCupPath baseDir "msys64") handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") - handleRm $ removeEmptyDirsRecursive removeDirIfEmptyOrIsSymlink (fromGHCupPath baseDir) + handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir) -- report files in baseDir that are left-over after -- the standard location deletions above diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 4aeec14..2bc8a04 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -133,7 +133,7 @@ mergeFileTree sourceBase destBase tool v' copyOp = do hideError NoSuchThing $ rmFile recFile logDebug $ "rm -f " <> T.pack (fromInstallDir destBase) hideError UnsatisfiedConstraints $ hideError NoSuchThing $ - removeEmptyDirsRecursive (hideError UnsatisfiedConstraints . liftIO . removeEmptyDirectory) (fromInstallDir destBase) + removeEmptyDirsRecursive (fromInstallDir destBase) recordInstalledFile f recFile = when (isSafeDir destBase) $ @@ -223,13 +223,13 @@ removeDirIfEmptyOrIsSymlink filepath = then rmFileForce fp else liftIO $ ioError e -removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => (FilePath -> m ()) -> FilePath -> m () -removeEmptyDirsRecursive rmOpt = go +removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () +removeEmptyDirsRecursive = go where go fp = do cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp ) forM_ cs go - hideError InappropriateType $ rmOpt fp + liftIO $ removeEmptyDirectory fp rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m () rmFileForce filepath = do