stack-clean-old (empty) → 0.1

raw patch · 5 files changed

+324/−0 lines, 5 filesdep +basedep +directorydep +extra

Dependencies added: base, directory, extra, filepath, simple-cmd, simple-cmd-args

Files

• ChangeLog.md +4/−0
• LICENSE +30/−0
• Main.hs +190/−0
• README.md +54/−0
• stack-clean-old.cabal +46/−0

@@ -0,0 +1,4 @@+# Revision history for stack-clean-old-work++## 0.1 (2020-09-xx)+- initial release with project and snapshots subcommands

@@ -0,0 +1,30 @@+Copyright (c) 2020, Jens Petersen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jens Petersen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}++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)+  hiding (ifM, whenM)+#endif+import SimpleCmdArgs+import System.Directory+import System.FilePath+import Text.Printf++import Paths_stack_clean_old (version)++main :: IO ()+main = do+  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 <*> ghcVerArg+      , Subcommand "remove-older" "purge older builds in .stack-work/install" $+        cleanOldStackWork <$> keepOption <*> 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 <$> 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 <$> ghcVerArg+      ]++    ]+  where+    notHumanOpt = switchWith 'H' "not-human-size" "Do not use du --human-readable"++    dirOption = optional (strOptionWith 'd' "dir" "PROJECTDIR" "Path to project")+    ghcVerArg = strArg "GHCVER"++    keepOption = positive <$> optionalWith auto 'k' "keep" "INT" "number of project builds per ghc version" 5++    positive :: Int -> Int+    positive n = if n > 0 then n else error' "Must be positive integer"++stackWorkInstall :: FilePath+stackWorkInstall = ".stack-work/install"++sizeStackWork :: Maybe FilePath -> Bool -> IO ()+sizeStackWork mdir nothuman = do+  let path = fromMaybe "" mdir </> stackWorkInstall+  whenM (doesDirectoryExist path) $+    cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", path]++printTotalGhcSize :: [FilePath] -> IO ()+printTotalGhcSize ds = do+  total <- head . words . last <$> cmdLines "du" ("-shc":ds)+  printf "%4s  %-6s (%d dirs)\n" total ((takeFileName . head) ds) (length ds)++setStackWorkDir :: Maybe FilePath -> IO ()+setStackWorkDir mdir = do+  whenJust mdir $ \ dir -> setCurrentDirectory dir+  switchToSystemDirUnder stackWorkInstall++setStackSnapshotsDir :: IO ()+setStackSnapshotsDir = do+  home <- getHomeDirectory+  switchToSystemDirUnder $ home </> ".stack/snapshots"++getSnapshotDirs :: IO [FilePath]+getSnapshotDirs = do+  lines <$> shell ( unwords $ "ls" : ["-d", "*/*"])++takeGhcSnapshots :: String -> [FilePath] -> [FilePath]+takeGhcSnapshots ghcver =+  map takeDirectory . filter ((== ghcver) . takeFileName)++sizeSnapshots :: Bool -> IO ()+sizeSnapshots nothuman = do+  home <- getHomeDirectory+  cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", home </> ".stack/snapshots"]++listGhcSnapshots :: IO () -> Maybe String -> IO ()+listGhcSnapshots setdir mghcver = do+  setdir+  dirs <- sortOn (readVersion . takeFileName) <$> getSnapshotDirs+  case mghcver of+    Nothing -> do+      let ghcs = groupOn takeFileName dirs+      mapM_ printTotalGhcSize ghcs+    Just ghcver -> do+      let ds = takeGhcSnapshots ghcver dirs+      unless (null dirs) $+        cmd_ "du" ("-shc":ds)++cleanGhcSnapshots :: IO () -> String -> IO ()+cleanGhcSnapshots setDir ghcver = do+  setDir+  dirs <- takeGhcSnapshots ghcver <$> getSnapshotDirs+  mapM_ removeDirectoryRecursive dirs+  putStrLn $ show (length dirs) ++ " snapshots removed for " ++ ghcver++switchToSystemDirUnder :: FilePath -> IO ()+switchToSystemDirUnder dir = do+  ifM (doesDirectoryExist dir)+    (setCurrentDirectory dir)+    (error' $ dir ++ "not found")+  systems <- listDirectory "."+  let system = case systems of+        [] -> error' $ "No OS system in " ++ dir+        [sys] -> sys+        _ -> error' "More than one OS systems found " ++ dir ++ " (unsupported)"+  setCurrentDirectory system++cleanOldStackWork :: Int -> Maybe FilePath -> IO ()+cleanOldStackWork keep mdir = do+  setStackWorkDir mdir+  dirs <- sortOn takeFileName . lines <$> shell ( unwords $ "ls" : ["-d", "*/*"])+  let ghcs = groupOn takeFileName dirs+  mapM_ removeOlder ghcs+  where+    removeOlder :: [FilePath] -> IO ()+    removeOlder dirs = do+      let ghcver = (takeFileName . head) dirs+      oldfiles <- drop keep . reverse <$> sortedByAge+      mapM_ (removeDirectoryRecursive . takeDirectory) oldfiles+      unless (null oldfiles) $+        putStrLn $ show (length oldfiles) ++ " dirs removed for " ++ ghcver+      where+        sortedByAge = do+          fileTimes <- mapM newestTimeStamp dirs+          return $ map fst $ sortOn snd fileTimes++        newestTimeStamp dir = do+          withCurrentDirectory dir $ do+            files <- listDirectory "."+            timestamp <- maximum <$> mapM getModificationTime files+            return (dir, timestamp)++stackProgramsDir :: FilePath+stackProgramsDir = ".stack/programs"++sizeGhcInstalls :: Bool -> IO ()+sizeGhcInstalls nothuman = do+  home <- getHomeDirectory+  cmd_ "du" $ ["-h" | not nothuman] ++ ["-s", home </> stackProgramsDir]++setStackProgramsDir :: IO ()+setStackProgramsDir = do+  home <- getHomeDirectory+  switchToSystemDirUnder $ home </> stackProgramsDir++getGhcInstallDirs :: IO [FilePath]+getGhcInstallDirs = do+  setStackProgramsDir+  listDirectory "." >>= fmap sort . filterM doesDirectoryExist++listGhcInstallation :: Maybe String -> IO ()+listGhcInstallation mghcver = do+  dirs <- getGhcInstallDirs+  mapM_ putStrLn $ case mghcver of+    Nothing -> dirs+    Just ghcver -> filter (ghcver `isSuffixOf`) 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!!"

@@ -0,0 +1,54 @@+# stack-clean-old++A small tool to clean away older Haskell [stack](https://docs.haskellstack.org)+snapshot builds and ghc versions, to recover diskspace.++## Usage+```+stack-clean-old [project|snapshots|ghc] [size|list|remove-version] [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/`).++`size`:+    prints the total size of the above directory+    (`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).++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.++### Purging older stack project builds+```+stack-clean-old project remove-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 multiple branches/tags against the same LTS or ghc version then it is probably safer to avoid using `remove-older`.++## Installation++Run `stack install` or `cabal install`++## 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. Bug reports, suggestions, and improvements are welcome.

@@ -0,0 +1,46 @@+name:                stack-clean-old+version:             0.1+synopsis:            Clean away old stack build artefacts+description:+        A tool for cleaning away old stack snapshots and stack-work builds+        to recover diskspace.+license:             BSD3+license-file:        LICENSE+author:              Jens Petersen <juhpetersen@gmail.com>+maintainer:          Jens Petersen <juhpetersen@gmail.com>+copyright:           2020  Jens Petersen <juhpetersen@gmail.com>+homepage:            https://github.com/juhp/stack-clean-old+bug-reports:         https://github.com/juhp/stack-clean-old/issues+build-type:          Simple+category:            Distribution+extra-doc-files:     README.md+                     ChangeLog.md+cabal-version:       1.18++source-repository head+  type:                git+  location:            https://github.com/juhp/stack-clean-old.git++executable stack-clean-old+  main-is:             Main.hs+  other-modules:       Paths_stack_clean_old+--  hs-source-dirs:      app+  build-depends:       base < 5+                     , directory+                     , extra+                     , filepath+                     , simple-cmd >= 0.1.4+                     , simple-cmd-args >= 0.1.2+  default-language:    Haskell2010+  ghc-options:         -Wall+  if impl(ghc >= 8.0)+    ghc-options:       -Wcompat+                       -Widentities+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+                       -Wredundant-constraints+  if impl(ghc >= 8.2)+    ghc-options:       -fhide-source-paths+  if impl(ghc >= 8.4)+    ghc-options:       -Wmissing-export-lists+                       -Wpartial-fields