hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Some fixes

Browse Source
This commit is contained in:
Julian Ospald 2022-05-20 00:46:50 +02:00
parent d5efc86d85
commit c9e1261af2
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
3 changed files with 8 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitlab/script/ghcup_version.sh
View File

@ -289,6 +289,7 @@ fi
eghcup upgrade eghcup upgrade
eghcup upgrade -f 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/
mkdir no_nuke/bar mkdir no_nuke/bar
echo 'foo' > no_nuke/file echo 'foo' > no_nuke/file

6
lib/GHCup.hs
View File

@ -1809,7 +1809,7 @@ rmGHCVer ver = do
Just files -> do Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack dir lift $ logInfo $ "Removing files safely from: " <> T.pack dir
forM_ files (lift . recycleFile . (\f -> dir </> dropDrive f)) forM_ files (lift . recycleFile . (\f -> dir </> dropDrive f))
removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) dir removeEmptyDirsRecursive dir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
f <- recordedInstallationFile GHC ver f <- recordedInstallationFile GHC ver
lift $ recycleFile f lift $ recycleFile f
@ -1893,7 +1893,7 @@ rmHLSVer ver = do
Just files -> do Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
forM_ files (lift . recycleFile . (\f -> hlsDir </> dropDrive f)) forM_ files (lift . recycleFile . (\f -> hlsDir </> dropDrive f))
removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) hlsDir removeEmptyDirsRecursive hlsDir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir
f <- recordedInstallationFile HLS (mkTVer ver) f <- recordedInstallationFile HLS (mkTVer ver)
lift $ recycleFile f lift $ recycleFile f
@ -2049,7 +2049,7 @@ rmGhcupDirs = do
logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64") logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64")
handleRm $ removeEmptyDirsRecursive removeDirIfEmptyOrIsSymlink (fromGHCupPath baseDir) handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir)
-- report files in baseDir that are left-over after -- report files in baseDir that are left-over after
-- the standard location deletions above -- the standard location deletions above

8
lib/GHCup/Utils/File.hs
View File

@ -133,7 +133,7 @@ mergeFileTree sourceBase destBase tool v' copyOp = do
hideError NoSuchThing $ rmFile recFile hideError NoSuchThing $ rmFile recFile
logDebug $ "rm -f " <> T.pack (fromInstallDir destBase) logDebug $ "rm -f " <> T.pack (fromInstallDir destBase)
hideError UnsatisfiedConstraints $ hideError NoSuchThing $ hideError UnsatisfiedConstraints $ hideError NoSuchThing $
removeEmptyDirsRecursive (hideError UnsatisfiedConstraints . liftIO . removeEmptyDirectory) (fromInstallDir destBase) removeEmptyDirsRecursive (fromInstallDir destBase)
recordInstalledFile f recFile = when (isSafeDir destBase) $ recordInstalledFile f recFile = when (isSafeDir destBase) $
@ -223,13 +223,13 @@ removeDirIfEmptyOrIsSymlink filepath =
then rmFileForce fp then rmFileForce fp
else liftIO $ ioError e else liftIO $ ioError e
removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => (FilePath -> m ()) -> FilePath -> m () removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive rmOpt = go removeEmptyDirsRecursive = go
where where
go fp = do go fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>) cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs go forM_ cs go
hideError InappropriateType $ rmOpt fp liftIO $ removeEmptyDirectory fp
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m () rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce filepath = do rmFileForce filepath = do