Clean up and fix nuke command
This commit is contained in:
parent
c74784a37c
commit
8e820c6e89
GPG Key ID:
3786C5262ECB4A3F
@ -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
|
||||
|
||||
94
lib/GHCup.hs
94
lib/GHCup.hs
@ -1305,14 +1305,14 @@ 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
|
||||
@ -1320,14 +1320,11 @@ rmGhcup = do
|
||||
let tempFilepath = tempDir </> ghcupFilename
|
||||
hideError UnsupportedOperation $
|
||||
liftIO $ hideError NoSuchThing $
|
||||
Win32.moveFileEx ghcupFilepath (Just tempFilepath) 1
|
||||
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
|
||||
#else
|
||||
-- delete it.
|
||||
hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
|
||||
#endif
|
||||
else
|
||||
$logWarn $
|
||||
nonStandardInstallLocationMsg currentRunningExecPath
|
||||
|
||||
where
|
||||
handlePathNotPresent fp _err = do
|
||||
@ -1348,24 +1345,15 @@ 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
|
||||
@ -1374,57 +1362,57 @@ rmGhcupDirs :: ( MonadReader AppState m
|
||||
, MonadMask m )
|
||||
=> 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
|
||||
rmConfFile confFilePath
|
||||
|
||||
-- remove entire cache Dir
|
||||
rmCacheDir cacheDir
|
||||
|
||||
-- remove entire logs Dir
|
||||
rmLogsDir logsDir
|
||||
|
||||
-- remove bin directory conditionally
|
||||
rmBinDir binDir
|
||||
#if defined(IS_WINDOWS)
|
||||
rmPath (baseDir </> "msys64")
|
||||
#endif
|
||||
|
||||
-- report files in baseDir that are left-over after the standard location deletions above
|
||||
reportRemainingFiles baseDir
|
||||
liftIO $ removeEmptyDirsRecursive 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 ]--
|
||||
------------------
|
||||
|
||||
@ -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,6 +334,7 @@ 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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user