diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2da1b12..2188c61 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -103,6 +103,7 @@ data Command | Upgrade UpgradeOpts Bool | ToolRequirements | ChangeLog ChangeLogOptions + | Nuke #if defined(BRICK) | Interactive #endif @@ -219,7 +220,7 @@ invertableSwitch' -> Mod FlagFields Bool -- ^ option modifier for --no-foo -> Parser (Maybe Bool) invertableSwitch' longopt shortopt defv enmod dismod = optional - ( flag' True (enmod <> long longopt <> if defv then mempty else short shortopt) + ( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt) <|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty) ) where @@ -368,6 +369,14 @@ com = ) <> internal ) + <|> subparser + (command + "nuke" + (info (pure Nuke <**> helper) + (progDesc "Completely remove ghcup from your system")) + <> commandGroup "Nuclear Commands:" + ) + where installToolFooter :: String installToolFooter = [s|Discussion: @@ -393,7 +402,6 @@ com = By default returns the URI of the ChangeLog of the latest GHC release. Pass '-o' to automatically open via xdg-open.|] - installCabalFooter :: String installCabalFooter = [s|Discussion: Installs the specified cabal-install version (or a recommended default one) @@ -1693,9 +1701,45 @@ Make sure to clean up #{tmpdir} afterwards.|]) >> pure (ExitFailure 13) else putStrLn uri' >> pure ExitSuccess + 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." + liftIO $ threadDelay 10000000 -- wait 10s + + lift $ runLogger $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀" + lift $ runLogger $ $logInfo "Nuking in 3...2...1" + + + lInstalled <- lift $ runLogger . flip runReaderT appstate $ listVersions Nothing (Just ListInstalled) + + forM_ lInstalled (liftE . rmTool) + + leftOverFiles <- lift $ runLogger $ runReaderT rmGhcupDirs appstate + pure leftOverFiles + + ) >>= \case + VRight leftOverFiles -> do + + case length leftOverFiles of + 0 -> 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) + pure ExitSuccess + + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 15 + + case res of ExitSuccess -> pure () ef@(ExitFailure _) -> exitWith ef + + pure () fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 372a422..1c1ce27 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1282,6 +1282,196 @@ rmStackVer ver = do Nothing -> liftIO $ rmLink (binDir "stack" <> exeExt) +-- assuming the current scheme of having just 1 ghcup bin, no version info is required. +rmGhcup :: ( MonadReader AppState m + , MonadIO m + , MonadCatch m + , MonadLogger m + ) + => m () + +rmGhcup = do + AppState {dirs = Dirs {binDir}} <- ask + let ghcupFilename = "ghcup" <> exeExt + let ghcupFilepath = binDir ghcupFilename + + currentRunningExecPath <- liftIO $ getExecutablePath + + -- if paths do no exist, warn user, and continue to compare them, as is, + -- which should eventually fail and result in a non-standard install warning + + p1 <- handleIO' doesNotExistErrorType + (handlePathNotPresent currentRunningExecPath) + (liftIO $ canonicalizePath currentRunningExecPath) + + p2 <- handleIO' doesNotExistErrorType + (handlePathNotPresent ghcupFilename) + (liftIO $ canonicalizePath ghcupFilename) + + let areEqualPaths = equalFilePath p1 p2 + + if areEqualPaths + then + do +#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 +#else + -- delete it. + hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath +#endif + else + $logWarn $ + nonStandardInstallLocationMsg currentRunningExecPath + + where + handlePathNotPresent fp _err = do + $logDebug $ "Error: The path does not exist, " <> T.pack fp + pure fp + + nonStandardInstallLocationMsg path = T.pack $ + "current ghcup is invoked from a non-standard location: \n" + <> path <> + "\n you may have to uninstall it manually." + +rmTool :: ( MonadReader AppState m + , MonadLogger m + , MonadFail m + , MonadMask m + , MonadUnliftIO m) + => ListResult + -> Excepts '[NotInstalled ] m () + +rmTool ListResult {lVer, lTool, lCross} = do + -- appstate <- ask + + case lTool of + GHC -> do + let ghcTargetVersion = GHCTargetVersion lCross lVer + rmGHCVer ghcTargetVersion + + 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] +rmGhcupDirs = do + dirs@Dirs + { baseDir + , binDir + , logsDir + , cacheDir + , confDir } <- 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 + + -- report files in baseDir that are left-over after the standard location deletions above + reportRemainingFiles baseDir + + where + + rmEnvFile enFilePath = do + $logInfo "Removing Ghcup Environment File" + hideError doesNotExistErrorType $ liftIO $ deleteFile enFilePath + + rmConfFile confFilePath = do + $logInfo "removing Ghcup Config File" + hideError doesNotExistErrorType $ liftIO $ deleteFile confFilePath + + rmCacheDir cacheDir = do + $logInfo "removing ghcup cache Dir" + contents <- liftIO $ listDirectory cacheDir + forM_ contents deleteFile + removeDirIfEmptyOrIsSymlink cacheDir + + rmLogsDir logsDir = do + $logInfo "removing ghcup logs Dir" + contents <- liftIO $ listDirectory logsDir + forM_ contents deleteFile + removeDirIfEmptyOrIsSymlink logsDir + + rmBinDir binDir = do +#if !defined(IS_WINDOWS) + isXDGStyle <- liftIO $ useXDG + if not isXDGStyle + then removeDirIfEmptyOrIsSymlink binDir + else pure () +#else + removeDirIfEmptyOrIsSymlink binDir +#endif + + reportRemainingFiles ghcupDir = do + remainingFiles <- liftIO $ getDirectoryContentsRecursive ghcupDir + let normalizedFilePaths = fmap normalise remainingFiles + let sortedByDepthRemainingFiles = reverse $ sortBy compareFn normalizedFilePaths + remainingFilesAbsolute <- makePathsAbsolute sortedByDepthRemainingFiles + + pure remainingFilesAbsolute + + where + calcDepth :: FilePath -> Int + calcDepth = length . filter isPathSeparator + + 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 + + -- 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 = do + hideError InappropriateType $ rmFile filepath + + removeDirIfEmptyOrIsSymlink 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 ]-- diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index ba90660..ec680e7 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -26,6 +26,10 @@ module GHCup.Utils.Dirs , parseGHCupGHCDir , relativeSymlink , withGHCupTmpDir + , getConfigFilePath +#if !defined(IS_WINDOWS) + , useXDG +#endif ) where @@ -201,13 +205,16 @@ getDirs = do --[ GHCup files ]-- ------------------- +getConfigFilePath :: (MonadIO m) => m FilePath +getConfigFilePath = do + confDir <- liftIO ghcupConfigDir + pure $ confDir "config.yaml" ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings ghcupConfigFile = do - confDir <- liftIO ghcupConfigDir - let file = confDir "config.yaml" - contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file + filepath <- getConfigFilePath + contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath case contents of Nothing -> pure defaultUserSettings Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents' diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 9dd45f0..b31f700 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -340,31 +340,31 @@ copyDirectoryRecursive srcDir destDir = do -- 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 [""] +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') + collect files dirs' [] = return (reverse files + ,reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries - where - collect files dirs' [] = return (reverse files - ,reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False -- https://github.com/haskell/directory/issues/110 -- https://github.com/haskell/directory/issues/96