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

Clean up and fix nuke command

Browse Source
This commit is contained in:
Julian Ospald 2021-07-02 23:26:07 +02:00
parent c74784a37c
commit 8e820c6e89
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
3 changed files with 82 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
app/ghcup/Main.hs
View File

@ -1113,7 +1113,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, rawOutter = B.appendFile logfile
, rawOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> B.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
@ -1703,31 +1706,27 @@ Make sure to clean up #{tmpdir} afterwards.|])
Nuke ->
runRm (do
lift $ runLogger $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ runLogger $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
lift $ runLogger $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ runLogger $ $logInfo "Nuking in 3...2...1"
lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ $logInfo "Nuking in 3...2...1"
lInstalled <- lift $ runLogger . flip runReaderT appstate $ listVersions Nothing (Just ListInstalled)
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
forM_ lInstalled (liftE . rmTool)
leftOverFiles <- lift $ runLogger $ runReaderT rmGhcupDirs appstate
pure leftOverFiles
lift rmGhcupDirs
) >>= \case
VRight leftOverFiles -> do
case length leftOverFiles of
0 -> do
VRight leftOverFiles
| null leftOverFiles -> do
runLogger $ $logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
_ -> do
runLogger $ $logWarn "These Directories/Files have survived Nuclear Annihilation, you may remove them manually."
forM_ leftOverFiles (runLogger . $logDebug . T.pack)
| otherwise -> do
runLogger $ $logWarn "These Files have survived Nuclear Annihilation, you may remove them manually."
forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do

116
lib/GHCup.hs
View File

@ -1305,29 +1305,26 @@ rmGhcup = do
(liftIO $ canonicalizePath currentRunningExecPath)
p2 <- handleIO' doesNotExistErrorType
(handlePathNotPresent ghcupFilename)
(liftIO $ canonicalizePath ghcupFilename)
(handlePathNotPresent ghcupFilepath)
(liftIO $ canonicalizePath ghcupFilepath)
let areEqualPaths = equalFilePath p1 p2
if areEqualPaths
then
do
when (not areEqualPaths) $ do
$logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS)
-- since it doesn't seem possible to delete a running exec in windows
-- we move it to temp dir, to be deleted at next reboot
tempDir <- liftIO $ getTemporaryDirectory
let tempFilepath = tempDir </> ghcupFilename
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just tempFilepath) 1
-- since it doesn't seem possible to delete a running exec in windows
-- we move it to temp dir, to be deleted at next reboot
tempDir <- liftIO $ getTemporaryDirectory
let tempFilepath = tempDir </> ghcupFilename
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
#else
-- delete it.
hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
-- delete it.
hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
#endif
else
$logWarn $
nonStandardInstallLocationMsg currentRunningExecPath
where
handlePathNotPresent fp _err = do
@ -1348,83 +1345,74 @@ rmTool :: ( MonadReader AppState m
-> Excepts '[NotInstalled ] m ()
rmTool ListResult {lVer, lTool, lCross} = do
-- appstate <- ask
case lTool of
GHC -> do
GHC ->
let ghcTargetVersion = GHCTargetVersion lCross lVer
rmGHCVer ghcTargetVersion
in rmGHCVer ghcTargetVersion
HLS -> rmHLSVer lVer
Cabal -> rmCabalVer lVer
Stack -> rmStackVer lVer
GHCup -> lift rmGhcup
HLS -> do
rmHLSVer lVer
Cabal -> do
rmCabalVer lVer
Stack -> do
rmStackVer lVer
GHCup -> do
lift rmGhcup
rmGhcupDirs :: ( MonadReader AppState m
, MonadIO m
, MonadLogger m
, MonadCatch m
, MonadMask m )
=> m [FilePath]
=> m [FilePath]
rmGhcupDirs = do
dirs@Dirs
Dirs
{ baseDir
, binDir
, logsDir
, cacheDir
, confDir } <- asks dirs
} <- asks dirs
let envFilePath = baseDir </> "env"
confFilePath <- getConfigFilePath
-- remove env File
rmEnvFile envFilePath
-- remove the configFile file
rmEnvFile envFilePath
rmConfFile confFilePath
-- remove entire cache Dir
rmCacheDir cacheDir
rmLogsDir logsDir
rmBinDir binDir
#if defined(IS_WINDOWS)
rmPath (baseDir </> "msys64")
#endif
-- remove entire logs Dir
rmLogsDir logsDir
liftIO $ removeEmptyDirsRecursive baseDir
-- remove bin directory conditionally
rmBinDir binDir
-- report files in baseDir that are left-over after the standard location deletions above
reportRemainingFiles baseDir
-- report files in baseDir that are left-over after
-- the standard location deletions above
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where
rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File"
hideError doesNotExistErrorType $ liftIO $ deleteFile enFilePath
rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File"
hideError doesNotExistErrorType $ liftIO $ deleteFile confFilePath
rmCacheDir :: (MonadLogger m, MonadIO m) => FilePath -> m ()
rmCacheDir cacheDir = do
$logInfo "removing ghcup cache Dir"
contents <- liftIO $ listDirectory cacheDir
forM_ contents deleteFile
removeDirIfEmptyOrIsSymlink cacheDir
contents <- liftIO $ getDirectoryContentsRecursive cacheDir
forM_ contents (liftIO . deleteFile . (cacheDir </>))
rmLogsDir :: (MonadLogger m, MonadIO m) => FilePath -> m ()
rmLogsDir logsDir = do
$logInfo "removing ghcup logs Dir"
contents <- liftIO $ listDirectory logsDir
forM_ contents deleteFile
removeDirIfEmptyOrIsSymlink logsDir
contents <- liftIO $ getDirectoryContentsRecursive logsDir
forM_ contents (liftIO . deleteFile . (logsDir </>))
rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
rmBinDir binDir = do
#if !defined(IS_WINDOWS)
isXDGStyle <- liftIO $ useXDG
@ -1435,11 +1423,12 @@ rmGhcupDirs = do
removeDirIfEmptyOrIsSymlink binDir
#endif
reportRemainingFiles ghcupDir = do
remainingFiles <- liftIO $ getDirectoryContentsRecursive ghcupDir
reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
reportRemainingFiles dir = do
remainingFiles <- liftIO $ getDirectoryContentsRecursive dir
let normalizedFilePaths = fmap normalise remainingFiles
let sortedByDepthRemainingFiles = reverse $ sortBy compareFn normalizedFilePaths
remainingFilesAbsolute <- makePathsAbsolute sortedByDepthRemainingFiles
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
pure remainingFilesAbsolute
@ -1450,17 +1439,22 @@ rmGhcupDirs = do
compareFn :: FilePath -> FilePath -> Ordering
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
makePathsAbsolute :: (MonadIO m) => [FilePath] -> m [FilePath]
makePathsAbsolute paths = liftIO $
traverse (makeAbsolute . normalise) paths
removeEmptyDirsRecursive :: FilePath -> IO ()
removeEmptyDirsRecursive fp = do
cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
-- we expect only files inside cache/log dir
-- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below.
deleteFile :: FilePath -> IO ()
deleteFile filepath = do
hideError InappropriateType $ rmFile filepath
removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
@ -1473,6 +1467,8 @@ rmGhcupDirs = do
then liftIO $ deleteFile fp
else liftIO $ ioError e
------------------
--[ Debug info ]--
------------------

21
lib/GHCup/Utils/Prelude.hs
View File

@ -190,14 +190,14 @@ hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
hideErrorDef errs def =
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
hideErrorDefM :: [IOErrorType] -> IO a -> IO a -> IO a
hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
hideErrorDefM errs def =
handleIO (\e -> if ioeGetErrorType e `elem` errs then def else ioError e)
handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
-- TODO: does this work?
@ -334,12 +334,13 @@ copyDirectoryRecursive srcDir destDir = do
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where