Merge remote-tracking branch 'origin/merge-requests/101'
This commit is contained in:
commit
c74784a37c
GPG Key ID:
3786C5262ECB4A3F
@ -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)
|
||||
|
||||
190
lib/GHCup.hs
190
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 ]--
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user