handle symlink case when deleting directories in rmGhcupDirs
This commit is contained in:
parent
46fcdd356c
commit
59519febbc
19
lib/GHCup.hs
19
lib/GHCup.hs
@ -1381,19 +1381,19 @@ rmGhcupDirs = do
|
|||||||
$logInfo "removing ghcup cache Dir"
|
$logInfo "removing ghcup cache Dir"
|
||||||
contents <- liftIO $ listDirectory cacheDir
|
contents <- liftIO $ listDirectory cacheDir
|
||||||
forM_ contents deleteFile
|
forM_ contents deleteFile
|
||||||
removeDirIfEmpty cacheDir
|
removeDirIfEmptyOrIsSymlink cacheDir
|
||||||
|
|
||||||
rmLogsDir logsDir = do
|
rmLogsDir logsDir = do
|
||||||
$logInfo "removing ghcup logs Dir"
|
$logInfo "removing ghcup logs Dir"
|
||||||
contents <- liftIO $ listDirectory logsDir
|
contents <- liftIO $ listDirectory logsDir
|
||||||
forM_ contents deleteFile
|
forM_ contents deleteFile
|
||||||
removeDirIfEmpty logsDir
|
removeDirIfEmptyOrIsSymlink logsDir
|
||||||
|
|
||||||
rmBinDir binDir = do
|
rmBinDir binDir = do
|
||||||
#if !defined(IS_WINDOWS)
|
#if !defined(IS_WINDOWS)
|
||||||
isXDGStyle <- liftIO $ useXDG
|
isXDGStyle <- liftIO $ useXDG
|
||||||
if not isXDGStyle
|
if not isXDGStyle
|
||||||
then removeDirIfEmpty binDir
|
then removeDirIfEmptyOrIsSymlink binDir
|
||||||
else pure ()
|
else pure ()
|
||||||
#else
|
#else
|
||||||
removeDirIfEmpty binDir
|
removeDirIfEmpty binDir
|
||||||
@ -1402,8 +1402,17 @@ rmGhcupDirs = do
|
|||||||
deleteFile filepath = do
|
deleteFile filepath = do
|
||||||
hideError InappropriateType $ rmFile filepath
|
hideError InappropriateType $ rmFile filepath
|
||||||
|
|
||||||
removeDirIfEmpty filepath =
|
removeDirIfEmptyOrIsSymlink filepath =
|
||||||
hideError UnsatisfiedConstraints $ liftIO $ removeDirectory filepath
|
hideError UnsatisfiedConstraints $
|
||||||
|
handleIO' InappropriateType
|
||||||
|
(handleIfSym filepath)
|
||||||
|
(liftIO $ removeDirectory filepath)
|
||||||
|
where
|
||||||
|
handleIfSym fp e = do
|
||||||
|
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||||
|
if isSym
|
||||||
|
then liftIO $ deleteFile fp
|
||||||
|
else liftIO $ ioError e
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
--[ Debug info ]--
|
--[ Debug info ]--
|
||||||
|
Loading…
Reference in New Issue
Block a user