From 8e820c6e8912dd05e5e33eeecbef95af2587b58a Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 2 Jul 2021 23:26:07 +0200 Subject: [PATCH] Clean up and fix nuke command --- app/ghcup/Main.hs | 31 +++++----- lib/GHCup.hs | 116 ++++++++++++++++++------------------- lib/GHCup/Utils/Prelude.hs | 21 +++---- 3 files changed, 82 insertions(+), 86 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2188c61..726b305 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1113,7 +1113,10 @@ Report bugs at |] 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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 1c1ce27..c5b7e6f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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 ]-- ------------------ diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index b31f700..76fbd35 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -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