diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Revision history for stack-clean-old-work +## 0.3 (2021-01-08) +- drop subsubcommands to simplify UI +- default to project if there is a .stack-work/ dir, otherwise global ~/.stack +- rename commands: + - remove-version -> remove + - remove-earlier-minor -> keep-minor + - remove-older -> purge-older + - remove-work -> delete-work +- fix handling of partially installed ghc compiler temp dirs (#2) +- rename --dryrun to --dry-run (#1) +- drop --dir option +- delete-work: use --all to run from a non-project dir + ## 0.2.2 (2002-12-31) - add 'project remove-work' to recursively remove .stack-work from projects diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,93 +1,93 @@ # stack-clean-old A small tool to clean away older Haskell [stack](https://docs.haskellstack.org) -snapshot builds and ghc versions, to recover diskspace. +snapshot builds and ghc versions to recover diskspace. ## Usage ``` -stack-clean-old [project|snapshots|ghc] [size|list|remove-version|remove-earlier-minor] [GHCVER] +stack-clean-old [size|list|remove|keep-minor] [(-p|--project) | (-g|--ghc)] [GHCVER] ``` -These commands act respectively on: +Options: -- the current local **project**: `.stack-work/install/` -- the user's stack **snapshot** builds: `~/.stack/snapshots/` -- installed stack **ghc** compilers: `~/.stack/programs/`. +- `--project` (default in a stack project dir): act on `.stack-work/install/` +- `--global` (default outside a project dir): act on `~/.stack/snapshots/` and `~/.stack/programs/` and the subcommands: `size`: - prints the total size of the above directory + prints the total size of the above directories (`size` does not take a GHCVER argument). `list`: shows the total size and number of snapshots per ghc version (the GHCVER argument is optional). -`remove-version`: - removes all snapshots for the specified ghc version - (the GHCVER argument is required). +`remove`: + removes for the specified ghc version (the GHCVER argument is required). -`remove-earlier-minor`: +`keep-minor`: removes the builds/installs for previous minor ghc versions. If GHCVER is given then only minor versions older than it are removed. -NB: If you remove all snapshot builds for a version of ghc, then you would have to rebuild again for any projects still using them, so removal should be used cautiously, but it can recover a lot of diskspace. +If you remove any needed snapshot builds for a version of ghc, then you would have to rebuild them again for any projects still using them, so removal should be used cautiously, but it can recover a lot of diskspace. -NBB: All the command support `--dryrun` (`-n`) so you can check the effect +NBB: All the command support `--dry-run` (`-n`) so you can check the effect of running them safely beforehand. ### Example usage To remove project builds for ghc-8.2.2: ``` -$ stack-clean-old project list +$ stack-clean-old list 154M 8.2.2 (5 dirs) 154M 8.4.4 (5 dirs) 163M 8.6.5 (5 dirs) -$ stack-clean-old project remove-version 8.2.2 +$ stack-clean-old remove -p 8.2.2 ``` -Remove all stack ghc-8.4 snapshot builds before 8.4.4: +Remove stack ghc-8.4 snapshot builds and compilers before 8.4.4: ``` -$ stack-clean-old snapshots list 8.4 +$ stack-clean-old list -g 8.4 421M 8.4.1 (7 dirs) 368M 8.4.2 (6 dirs) 489M 8.4.3 (8 dirs) 799M 8.4.4 (24 dirs) -$ stack-clean-old snapshots remove-earlier-minor 8.4.4 +$ stack-clean-old keep-minor -g 8.4.4 +ghc-tinfo6-8.4.3 removed 7 dirs removed for 8.4.1 6 dirs removed for 8.4.2 8 dirs removed for 8.4.3 ``` -Incidently I build my projects across as many major Stackage LTS versions as possible, and collectively this piles up to a lot of diskspace: so I wrote this tool to help manage that. +Incidently I build my projects across as many major Stackage LTS versions as possible (using my stack-all tool), and collectively this piles up to a lot of diskspace: so I wrote this tool to help manage that. ### Purging older stack project builds ``` -stack-clean-old project remove-older +stack-clean-old purge-older ``` This command removes older stack builds from `.stack-work/install/`. By default it keeps 5 newest builds per ghc version. The preservation/deletion is calculated and done per ghc version. -NB: If you regularly build your project for several branches/tags against the same LTS or ghc version then it is safer to avoid using `remove-older`. +NB: If you regularly build your project for several branches/tags against the same LTS or ghc version then it is safer to avoid using `purge-older`. -Also `stack-clean-old project remove-work` can be used to recursively remove -all `.stack-work/` dirs from a project to save space. +Also `stack-clean-old delete-work` can be used to recursively remove +_all_ `.stack-work/` dirs from a project to save space (seems same as `stack clean --full`). ## Installation Run `stack install` or `cabal install` +## Related +This tool complements [stack-all](https://hackage.haskell.org/package/stack-all) +which builds projects over LTS major versions and hence generates lot of stack builds. + ## Contributing BSD license Project: https://github.com/juhp/stack-clean-old ## Warning disclaimer -Use at your own risk. - -The author takes no responsibility for any loss or damaged caused by using -this tool. +Use at your own risk: the author takes no responsibility for any loss or damaged caused by using this tool, as also mentioned in LICENSE. Bug reports, suggestions, and improvements are welcome. diff --git a/src/GHC.hs b/src/GHC.hs --- a/src/GHC.hs +++ b/src/GHC.hs @@ -42,12 +42,12 @@ ghcInstallVersion :: FilePath -> Version ghcInstallVersion = - readVersion . takeWhileEnd (/= '-') + readVersion . takeWhileEnd (/= '-') . dropSuffix ".temp" listGhcInstallation :: Maybe Version -> IO () listGhcInstallation mghcver = do dirs <- getGhcInstallDirs mghcver - mapM_ (putStrLn . showVersion . ghcInstallVersion) $ case mghcver of + mapM_ putStrLn $ case mghcver of Nothing -> dirs Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs @@ -55,11 +55,10 @@ removeGhcVersionInstallation dryrun ghcver = do installs <- getGhcInstallDirs (Just ghcver) case installs of - [] -> error' $ "stack ghc compiler version " ++ showVersion ghcver ++ " not found" + [] -> putStrLn $ "stack ghc compiler version " ++ showVersion ghcver ++ " not found" [g] | not (isMajorVersion ghcver) -> doRemoveGhcVersion dryrun g gs -> if isMajorVersion ghcver then do - putStr $ "Press Enter to delete all stack " ++ showVersion ghcver ++ " installations: " - void getLine + Remove.prompt dryrun ("all stack ghc " ++ showVersion ghcver ++ " installations: ") mapM_ (doRemoveGhcVersion dryrun) gs else error' "more than one match found!!" @@ -78,5 +77,5 @@ doRemoveGhcVersion :: Bool -> FilePath -> IO () doRemoveGhcVersion dryrun ghcinst = do Remove.doRemoveDirectory dryrun ghcinst - unless dryrun (Remove.removeFile (ghcinst <.> "installed")) - putStrLn $ ghcinst ++ " removed" + Remove.removeFile dryrun (ghcinst <.> "installed") + putStrLn $ ghcinst ++ "compiler " ++ (if dryrun then "would be " else "") ++ "removed" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,67 +1,116 @@ +{-# LANGUAGE CPP #-} + module Main (main) where +#if !MIN_VERSION_simple_cmd_args(0,1,3) +import Control.Applicative ((<|>)) +#endif import Data.Version.Extra import SimpleCmd import SimpleCmdArgs +import System.Directory import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) import GHC import Paths_stack_clean_old (version) import Snapshots +data Mode = Default | Project | Snapshots | Compilers | GHC + main :: IO () main = do hSetBuffering stdout NoBuffering simpleCmdArgs (Just version) "Stack clean up tool" "Cleans away old stack-work builds (and pending: stack snapshots) to recover diskspace." $ subcommands - [ Subcommand "project" "Commands for project .stack-work builds" $ - subcommands - [ Subcommand "size" "Total size of project's .stack-work/install" $ - sizeStackWork <$> dirOption <*> notHumanOpt - , Subcommand "list" "List builds in .stack-work/install per ghc version" $ - listGhcSnapshots . setStackWorkDir <$> dirOption <*> optional ghcVerArg - , Subcommand "remove-version" "Remove builds in .stack-work/install for a ghc version" $ - cleanGhcSnapshots . setStackWorkDir <$> dirOption <*> dryrun <*> ghcVerArg - , Subcommand "remove-earlier-minor" "Remove builds in .stack-work/install for previous ghc minor versions" $ - cleanMinorSnapshots . setStackWorkDir <$> dirOption <*> dryrun <*> optional ghcVerArg - , Subcommand "remove-older" "Purge older builds in .stack-work/install" $ - cleanOldStackWork <$> dryrun <*> keepOption <*> optional (strArg "PROJECTDIR") - , Subcommand "remove-work" "Remove .stack-work subdirs recursively" $ - removeStackWorks <$> dryrun <*> optional (strArg "PROJECTDIR") - ] - , Subcommand "snapshots" "Commands for ~/.stack/snapshots" $ - subcommands - [ Subcommand "size" "Total size of all stack build snapshots" $ - sizeSnapshots <$> notHumanOpt - , Subcommand "list" "List build snapshots per ghc version" $ - listGhcSnapshots setStackSnapshotsDir <$> optional ghcVerArg - , Subcommand "remove-version" "Remove build snapshots for a ghc version" $ - cleanGhcSnapshots setStackSnapshotsDir <$> dryrun <*> ghcVerArg - , Subcommand "remove-earlier-minor" "Remove build snapshots for previous ghc minor versions" $ - cleanMinorSnapshots setStackSnapshotsDir <$> dryrun <*> optional ghcVerArg - ] - , Subcommand "ghc" "Commands on stack's ghc compiler installations" $ - subcommands - [ Subcommand "size" "Total size of installed stack ghc compilers" $ - sizeGhcInstalls <$> notHumanOpt - , Subcommand "list" "List installed stack ghc compiler versions" $ - listGhcInstallation <$> optional ghcVerArg - , Subcommand "remove-version" "Remove installation of a stack ghc compiler version" $ - removeGhcVersionInstallation <$> dryrun <*> ghcVerArg - , Subcommand "remove-earlier-minor" "Remove installations of stack ghc previous minor versions" $ - removeGhcMinorInstallation <$> dryrun <*> optional ghcVerArg - ] + [ Subcommand "size" "Total size" $ + sizeCmd <$> modeOpt <*> notHumanOpt + , Subcommand "list" "List sizes per ghc version" $ + listCmd <$> modeOpt <*> optional ghcVerArg + , Subcommand "remove" "Remove for a ghc version" $ + removeCmd <$> dryrun <*> modeOpt <*> ghcVerArg + , Subcommand "keep-minor" "Remove for previous ghc minor versions" $ + removeMinorsCmd <$> dryrun <*> modeOpt <*> optional ghcVerArg + , Subcommand "purge-older" "Purge older builds in .stack-work/install" $ + cleanOldStackWork <$> dryrun <*> keepOption + , Subcommand "delete-work" "Remove project's .stack-work subdirs recursively" $ + removeStackWorks <$> dryrun <*> switchWith 'a' "all" "Find all .stack-work/ subdirs, even if current directory not a stack project" ] where - dryrun = switchWith 'n' "dryrun" "Show what would be done, without removing" + modeOpt = + flagWith' Project 'p' "project" "Act on current project's .stack-work/ [default in project dir]" <|> + flagWith' GHC 'g' "global" "Act on both ~/.stack/{programs,snapshots}/ [default outside project dir]" <|> + flagWith' Snapshots 's' "snapshots" "Act on ~/.stack/snapshots/" <|> + flagWith Default Compilers 'c' "compilers" "Act on ~/.stack/programs/" + dryrun = switchWith 'n' "dry-run" "Show what would be done, without removing" + notHumanOpt = switchWith 'H' "not-human-size" "Do not use du --human-readable" - dirOption = optional (strOptionWith 'd' "dir" "PROJECTDIR" "Path to project") ghcVerArg = readVersion <$> strArg "GHCVER" keepOption = positive <$> optionalWith auto 'k' "keep" "INT" "number of project builds per ghc version [default 5]" 5 positive :: Int -> Int positive n = if n > 0 then n else error' "Must be positive integer" + + +sizeCmd :: Mode -> Bool -> IO () +sizeCmd mode notHuman = + case mode of + Project -> sizeStackWork notHuman + Snapshots -> sizeSnapshots notHuman + Compilers -> sizeGhcInstalls notHuman + GHC -> do + sizeCmd Compilers notHuman + sizeCmd Snapshots notHuman + Default -> do + isProject <- doesDirectoryExist ".stack-work" + if isProject + then sizeCmd Project notHuman + else sizeCmd GHC notHuman + +listCmd :: Mode -> Maybe Version -> IO () +listCmd mode mver = + case mode of + Project -> listGhcSnapshots setStackWorkDir mver + Snapshots -> listGhcSnapshots setStackSnapshotsDir mver + Compilers -> listGhcInstallation mver + GHC -> do + listCmd Compilers mver + listCmd Snapshots mver + Default -> do + isProject <- doesDirectoryExist ".stack-work" + if isProject + then listCmd Project mver + else listCmd GHC mver + +removeCmd :: Bool -> Mode -> Version -> IO () +removeCmd dryrun mode ghcver = + case mode of + Project -> cleanGhcSnapshots setStackWorkDir dryrun ghcver + Snapshots -> cleanGhcSnapshots setStackSnapshotsDir dryrun ghcver + Compilers -> removeGhcVersionInstallation dryrun ghcver + GHC -> do + removeCmd dryrun Compilers ghcver + removeCmd dryrun Snapshots ghcver + Default -> do + isProject <- doesDirectoryExist ".stack-work" + if isProject + then removeCmd dryrun Project ghcver + else removeCmd dryrun GHC ghcver + +removeMinorsCmd :: Bool -> Mode -> Maybe Version -> IO () +removeMinorsCmd dryrun mode mver = + case mode of + Project -> cleanMinorSnapshots setStackWorkDir dryrun mver + Snapshots -> cleanMinorSnapshots setStackSnapshotsDir dryrun mver + Compilers -> removeGhcMinorInstallation dryrun mver + GHC -> do + removeMinorsCmd dryrun Compilers mver + removeMinorsCmd dryrun Snapshots mver + Default -> do + isProject <- doesDirectoryExist ".stack-work" + if isProject + then removeMinorsCmd dryrun Project mver + else removeMinorsCmd dryrun GHC mver diff --git a/src/Remove.hs b/src/Remove.hs --- a/src/Remove.hs +++ b/src/Remove.hs @@ -1,13 +1,26 @@ module Remove ( doRemoveDirectory, + prompt, removeFile ) where -import Control.Monad -import System.Directory +import Control.Monad.Extra +import qualified System.Directory as D doRemoveDirectory :: Bool -> FilePath -> IO () doRemoveDirectory dryrun dir = unless dryrun $ - removeDirectoryRecursive dir + D.removeDirectoryRecursive dir + +removeFile :: Bool -> FilePath -> IO () +removeFile dryrun file = + unless dryrun $ + whenM (D.doesFileExist file) $ + D.removeFile file + +prompt :: Bool -> String -> IO () +prompt dryrun str = + unless dryrun $ do + putStr $ "Press Enter to delete " ++ str ++ ": " + void getLine diff --git a/src/Snapshots.hs b/src/Snapshots.hs --- a/src/Snapshots.hs +++ b/src/Snapshots.hs @@ -17,7 +17,6 @@ import Control.Monad.Extra import Data.List.Extra -import Data.Maybe import Data.Version.Extra import SimpleCmd #if MIN_VERSION_simple_cmd(0,2,1) @@ -90,15 +89,14 @@ removeVersionSnaps dryrun versnap = do let dirs = snapsHashes versnap mapM_ (Remove.doRemoveDirectory dryrun) dirs - putStrLn $ show (length dirs) ++ " snapshots removed for " ++ showVersion (snapsVersion versnap) + putStrLn $ show (length dirs) ++ " dirs in ~/.stack/snapshots/ " ++ (if dryrun then "would be " else "") ++ "removed for " ++ showVersion (snapsVersion versnap) cleanGhcSnapshots :: IO () -> Bool -> Version -> IO () cleanGhcSnapshots setDir dryrun ghcver = do setDir ghcs <- getSnapshotDirs (Just ghcver) when (isMajorVersion ghcver) $ do - putStr $ "Press Enter to delete all " ++ showVersion ghcver ++ " builds: " - void getLine + Remove.prompt dryrun ("all " ++ showVersion ghcver ++ " builds") mapM_ (removeVersionSnaps dryrun) ghcs cleanMinorSnapshots :: IO () -> Bool -> Maybe Version -> IO () @@ -118,9 +116,9 @@ gminors = filter ((< newestMinor) . snapsVersion) ghcs mapM_ (removeVersionSnaps dryrun) gminors -cleanOldStackWork :: Bool -> Int -> Maybe FilePath -> IO () -cleanOldStackWork dryrun keep mdir = do - setStackWorkDir mdir +cleanOldStackWork :: Bool -> Int -> IO () +cleanOldStackWork dryrun keep = do + setStackWorkDir dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) let ghcs = groupOn takeFileName dirs mapM_ removeOlder ghcs @@ -146,9 +144,9 @@ stackWorkInstall :: FilePath stackWorkInstall = ".stack-work/install" -sizeStackWork :: Maybe FilePath -> Bool -> IO () -sizeStackWork mdir nothuman = do - let path = fromMaybe "" mdir stackWorkInstall +sizeStackWork :: Bool -> IO () +sizeStackWork nothuman = do + let path = stackWorkInstall whenM (doesDirectoryExist path) $ cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", path] @@ -157,21 +155,23 @@ total <- head . words . last <$> cmdLines "du" ("-shc":snapsHashes versnaps) printf "%4s %-6s (%d dirs)\n" total ((showVersion . snapsVersion) versnaps) (length (snapsHashes versnaps)) -setStackWorkDir :: Maybe FilePath -> IO () -setStackWorkDir mdir = do - whenJust mdir setCurrentDirectory +setStackWorkDir :: IO () +setStackWorkDir = do switchToSystemDirUnder stackWorkInstall setStackSnapshotsDir :: IO () setStackSnapshotsDir = do getStackSubdir "snapshots" >>= switchToSystemDirUnder -removeStackWorks :: Bool -> Maybe FilePath -> IO () -removeStackWorks dryrun mdir = do - whenJust mdir setCurrentDirectory - workdirs <- sort <$> cmdLines "find" ["-type", "d", "-name", ".stack-work"] - unless (null workdirs) $ do - mapM_ putStrLn workdirs - putStr "Press Enter to delete these dirs: " - void getLine - mapM_ (Remove.doRemoveDirectory dryrun) workdirs +removeStackWorks :: Bool -> Bool -> IO () +removeStackWorks dryrun allrecurse = do + recurse <- + if allrecurse then return True + else doesDirectoryExist ".stack-work" + if recurse then do + workdirs <- sort <$> cmdLines "find" ["-type", "d", "-name", ".stack-work"] + unless (null workdirs) $ do + mapM_ putStrLn workdirs + Remove.prompt dryrun "these dirs" + mapM_ (Remove.doRemoveDirectory dryrun) workdirs + else error' "run in a project dir (containing .stack-work/)\n or use --all to find and remove all .stack-work/ subdirectories" diff --git a/stack-clean-old.cabal b/stack-clean-old.cabal --- a/stack-clean-old.cabal +++ b/stack-clean-old.cabal @@ -1,8 +1,9 @@ name: stack-clean-old -version: 0.2.2 +version: 0.3 synopsis: Clean away old stack build artefacts description: - A tool for cleaning away old .stack snapshots and .stack-work builds + A tool for removing old .stack-work/install builds and + .stack/snapshots & programs for older ghc versions to recover diskspace. license: BSD3 license-file: LICENSE