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

Clean up and fix nuke command

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

116
lib/GHCup.hs
View File

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