diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,10 @@ # Revision history for stack-clean-old-work -## 0.1 (2020-09-xx) +## 0.2 (2020-10-26) +- add --dryrun to all remove commands +- remove-earlier-minor subcommands to purge for previous ghc minor versions +- allow major ghc X.Y versions (prompts for removal) +- 'ghc list' is now sorted + +## 0.1 (2020-09-22) - initial release with project and snapshots subcommands diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -11,12 +11,14 @@ import SimpleCmdArgs import System.Directory import System.FilePath +import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) import Text.Printf import Paths_stack_clean_old (version) 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 @@ -24,12 +26,14 @@ 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" $ + , 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 <*> ghcVerArg - , Subcommand "remove-older" "purge older builds in .stack-work/install" $ - cleanOldStackWork <$> keepOption <*> optional (strArg "PROJECTDIR") + , 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 "snapshots" "Commands for ~/.stack/snapshots" $ subcommands @@ -38,7 +42,9 @@ , Subcommand "list" "List build snapshots per ghc version" $ listGhcSnapshots setStackSnapshotsDir <$> optional ghcVerArg , Subcommand "remove-version" "Remove build snapshots for a ghc version" $ - cleanGhcSnapshots setStackSnapshotsDir <$> ghcVerArg + 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 @@ -47,17 +53,20 @@ , Subcommand "list" "List installed stack ghc compiler versions" $ listGhcInstallation <$> optional ghcVerArg , Subcommand "remove-version" "Remove installation of a stack ghc compiler version" $ - removeGhcVersionInstallation <$> ghcVerArg + removeGhcVersionInstallation <$> dryrun <*> ghcVerArg + , Subcommand "remove-earlier-minor" "Remove installations of stack ghc previous minor versions" $ + removeGhcMinorInstallation <$> dryrun <*> optional ghcVerArg ] - ] where + dryrun = switchWith 'n' "dryrun" "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 = strArg "GHCVER" + ghcVerArg = readVersion <$> strArg "GHCVER" - keepOption = positive <$> optionalWith auto 'k' "keep" "INT" "number of project builds per ghc version" 5 + 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" @@ -90,16 +99,16 @@ getSnapshotDirs = do lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) -takeGhcSnapshots :: String -> [FilePath] -> [FilePath] +takeGhcSnapshots :: Version -> [FilePath] -> [FilePath] takeGhcSnapshots ghcver = - map takeDirectory . filter ((== ghcver) . takeFileName) + map takeDirectory . filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . readVersion . takeFileName) sizeSnapshots :: Bool -> IO () sizeSnapshots nothuman = do home <- getHomeDirectory cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", home ".stack/snapshots"] -listGhcSnapshots :: IO () -> Maybe String -> IO () +listGhcSnapshots :: IO () -> Maybe Version -> IO () listGhcSnapshots setdir mghcver = do setdir dirs <- sortOn (readVersion . takeFileName) <$> getSnapshotDirs @@ -107,18 +116,67 @@ Nothing -> do let ghcs = groupOn takeFileName dirs mapM_ printTotalGhcSize ghcs + Just ghcver | isMajorVersion ghcver -> do + let ghcs = groupOn takeFileName $ filter ((== ghcver) . majorVersion . readVersion . takeFileName) dirs + mapM_ printTotalGhcSize ghcs Just ghcver -> do let ds = takeGhcSnapshots ghcver dirs - unless (null dirs) $ + unless (null ds) $ cmd_ "du" ("-shc":ds) -cleanGhcSnapshots :: IO () -> String -> IO () -cleanGhcSnapshots setDir ghcver = do +doRemoveDirectory :: Bool -> FilePath -> IO () +doRemoveDirectory dryrun dir = + unless dryrun $ + removeDirectoryRecursive dir + +cleanGhcSnapshots :: IO () -> Bool -> Version -> IO () +cleanGhcSnapshots setDir dryrun ghcver = do setDir dirs <- takeGhcSnapshots ghcver <$> getSnapshotDirs - mapM_ removeDirectoryRecursive dirs - putStrLn $ show (length dirs) ++ " snapshots removed for " ++ ghcver + unless (dryrun || null dirs) $ + when (isMajorVersion ghcver) $ do + putStr $ "Press Enter to delete all " ++ showVersion ghcver ++ " builds: " + void getLine + unless (null dirs) $ do + mapM_ (doRemoveDirectory dryrun) dirs + putStrLn $ show (length dirs) ++ " snapshots removed for " ++ showVersion ghcver +cleanMinorSnapshots :: IO () -> Bool -> Maybe Version -> IO () +cleanMinorSnapshots setDir dryrun mghcver = do + setDir + dirs <- sortOn (readVersion . takeFileName) <$> getSnapshotDirs + case mghcver of + Nothing -> do + let ghcs = map (groupOn takeFileName) $ groupOn (majorVersion . readVersion) dirs + forM_ ghcs $ \ gmajor -> + when (length gmajor > 1) $ + forM_ (init gmajor) $ \ gminor -> do + mapM_ (doRemoveDirectory dryrun) gminor + putStrLn $ show (length gminor) ++ " snapshots removed for " ++ takeFileName (head gminor) + Just ghcver -> do + let major = + if length (versionBranch ghcver) == 2 + then majorVersion ghcver + else error' "Please specify minor version X.Y.Z" + gmajor = groupOn takeFileName $ filter (olderMinor major ghcver) dirs + when (length gmajor > 1) $ + forM_ (init gmajor) $ \ gminor -> do + mapM_ (doRemoveDirectory dryrun) gminor + putStrLn $ show (length gminor) ++ " snapshots removed for " ++ takeFileName (head gminor) + where + olderMinor :: Version -> Version -> FilePath -> Bool + olderMinor major ghcver d = + ((== major) . majorVersion . readVersion) d && + ((< ghcver) . readVersion . takeFileName) d + +majorVersion :: Version -> Version +majorVersion ver = + let vernums = versionBranch ver in + case length vernums of + 2 -> ver + 3 -> (makeVersion . init) vernums + _ -> error' $ "Bad ghc version " ++ showVersion ver + switchToSystemDirUnder :: FilePath -> IO () switchToSystemDirUnder dir = do ifM (doesDirectoryExist dir) @@ -131,8 +189,8 @@ _ -> error' "More than one OS systems found " ++ dir ++ " (unsupported)" setCurrentDirectory system -cleanOldStackWork :: Int -> Maybe FilePath -> IO () -cleanOldStackWork keep mdir = do +cleanOldStackWork :: Bool -> Int -> Maybe FilePath -> IO () +cleanOldStackWork dryrun keep mdir = do setStackWorkDir mdir dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"]) let ghcs = groupOn takeFileName dirs @@ -142,7 +200,7 @@ removeOlder dirs = do let ghcver = (takeFileName . head) dirs oldfiles <- drop keep . reverse <$> sortedByAge - mapM_ (removeDirectoryRecursive . takeDirectory) oldfiles + mapM_ (doRemoveDirectory dryrun . takeDirectory) oldfiles unless (null oldfiles) $ putStrLn $ show (length oldfiles) ++ " dirs removed for " ++ ghcver where @@ -174,17 +232,47 @@ setStackProgramsDir listDirectory "." >>= fmap sort . filterM doesDirectoryExist -listGhcInstallation :: Maybe String -> IO () +ghcInstallVersion :: FilePath -> Version +ghcInstallVersion = + readVersion . takeWhileEnd (/= '-') + +isMajorVersion :: Version -> Bool +isMajorVersion ver = + majorVersion ver == ver + +listGhcInstallation :: Maybe Version -> IO () listGhcInstallation mghcver = do - dirs <- getGhcInstallDirs + dirs <- sortOn ghcInstallVersion <$> getGhcInstallDirs mapM_ putStrLn $ case mghcver of Nothing -> dirs - Just ghcver -> filter (ghcver `isSuffixOf`) dirs + Just ghcver -> filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) dirs -removeGhcVersionInstallation :: String -> IO () -removeGhcVersionInstallation ghcver = do - dirs <- getGhcInstallDirs - case filter (ghcver `isSuffixOf`) dirs of - [] -> error' $ "stack ghc compiler version " ++ ghcver ++ " not found" - [g] -> removeDirectoryRecursive g >> removeFile (g <.> "installed") - _ -> error' "more than one match found!!" +removeGhcVersionInstallation :: Bool -> Version -> IO () +removeGhcVersionInstallation dryrun ghcver = do + installs <- filter ((== ghcver) . (if isMajorVersion ghcver then majorVersion else id) . ghcInstallVersion) <$> getGhcInstallDirs + case installs of + [] -> error' $ "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 + mapM_ (doRemoveGhcVersion dryrun) gs + else error' "more than one match found!!" + +removeGhcMinorInstallation :: Bool -> Maybe Version -> IO () +removeGhcMinorInstallation dryrun mghcver = do + dirs <- sortOn ghcInstallVersion <$> getGhcInstallDirs + case mghcver of + Nothing -> do + let majors = groupOn (majorVersion . ghcInstallVersion) dirs + forM_ majors $ \ minors -> + forM_ (init minors) $ doRemoveGhcVersion dryrun + Just ghcver -> do + let minors = filter ((== majorVersion ghcver) . majorVersion . readVersion) dirs + forM_ (init minors) $ doRemoveGhcVersion dryrun + +doRemoveGhcVersion :: Bool -> FilePath -> IO () +doRemoveGhcVersion dryrun ghcinst = do + doRemoveDirectory dryrun ghcinst + unless dryrun (removeFile (ghcinst <.> "installed")) + putStrLn $ ghcinst ++ " removed" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,14 +5,16 @@ ## Usage ``` -stack-clean-old [project|snapshots|ghc] [size|list|remove-version] [GHCVER] +stack-clean-old [project|snapshots|ghc] [size|list|remove-version|remove-earlier-minor] [GHCVER] ``` These commands act respectively on: -- the current local project (`.stack-work/install/`) -- the user's stack snapshot builds (`~/.stack/snapshots/`) -- installed stack ghc compilers (`~/.stack/programs/`). +- the current local **project**: `.stack-work/install/` +- the user's stack **snapshot** builds: `~/.stack/snapshots/` +- installed stack **ghc** compilers: `~/.stack/programs/`. +and the subcommands: + `size`: prints the total size of the above directory (`size` does not take a GHCVER argument). @@ -25,8 +27,37 @@ removes all snapshots for the specified ghc version (the GHCVER argument is required). +`remove-earlier-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. +### Example usage +To remove project builds for ghc-8.2.2: +``` +$ stack-clean-old project 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 +``` + +Remove all stack ghc-8.4 snapshot builds before 8.4.4: +``` +$ stack-clean-old snapshots list 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 +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. + ### Purging older stack project builds ``` stack-clean-old project remove-older @@ -36,7 +67,7 @@ The preservation/deletion is calculated and done per ghc version. -NB: If you regularly build multiple branches/tags against the same LTS or ghc version then it is probably 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 `remove-older`. ## Installation @@ -51,4 +82,6 @@ Use at your own risk. The author takes no responsibility for any loss or damaged caused by using -this tool. Bug reports, suggestions, and improvements are welcome. +this tool. + +Bug reports, suggestions, and improvements are welcome. 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,8 @@ name: stack-clean-old -version: 0.1 +version: 0.2 synopsis: Clean away old stack build artefacts description: - A tool for cleaning away old stack snapshots and stack-work builds + A tool for cleaning away old .stack snapshots and .stack-work builds to recover diskspace. license: BSD3 license-file: LICENSE @@ -26,8 +26,8 @@ other-modules: Paths_stack_clean_old -- hs-source-dirs: app build-depends: base < 5 - , directory - , extra + , directory >= 1.2.5 + , extra >= 1.4.3 , filepath , simple-cmd >= 0.1.4 , simple-cmd-args >= 0.1.2