mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
etc/diskspace: extend to also clean unpacked .stack-work builds
[skip ci]
This commit is contained in:
parent
67a7f60e6c
commit
04ee14c769
@ -3,19 +3,36 @@
|
||||
|
||||
-- Utility to remove old libs installed under .stack-work/ to save diskspace
|
||||
|
||||
-- Should be run in:
|
||||
-- work/*/unpack-dir/.stack-work/install/x86_64-linux/*/*/lib/x86_64-linux-ghc-*
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Environment
|
||||
import Text.Regex.TDFA
|
||||
|
||||
-- keep 2 latest builds
|
||||
keepBuilds :: Int
|
||||
keepBuilds = 2
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
[stream] -> do
|
||||
home <- getHomeDirectory
|
||||
withCurrentDirectory (home </> "stackage/automated/work" </> stream </> "unpack-dir") $ do
|
||||
cleanStackWorkInstall
|
||||
cleanStackWorkPackages
|
||||
_ -> error "arg should be 'lts' or 'nightly'"
|
||||
|
||||
-- navigates to: .stack-work/install/x86_64-linux*/*/*/lib/x86_64-linux-ghc-*
|
||||
cleanStackWorkInstall :: IO ()
|
||||
cleanStackWorkInstall =
|
||||
withCurrentDirectory ".stack-work/install"
|
||||
$ withOneDirectory_ -- "x86_64-linux*"
|
||||
$ withOneDirectory_ -- hash
|
||||
$ withOneDirectory $ \ghcver ->
|
||||
withCurrentDirectory ("lib" </> "x86_64-linux-ghc-" ++ ghcver) $ do
|
||||
files <- sort <$> listDirectory "."
|
||||
let (dynlibs,libdirs) = partition (".so" `isExtensionOf`) files
|
||||
pkglibdirs = groupBy samePkgLibDir libdirs
|
||||
@ -45,13 +62,41 @@ main = do
|
||||
|
||||
removeDashSegment = dropWhileEnd (/= '-')
|
||||
|
||||
removeOlder remover files = do
|
||||
oldfiles <- drop keepBuilds . reverse <$> sortByAge files
|
||||
mapM_ remover oldfiles
|
||||
|
||||
removeOlder remover files = do
|
||||
oldfiles <- drop keepBuilds . reverse <$> sortByAge files
|
||||
mapM_ remover oldfiles
|
||||
where
|
||||
sortByAge files = do
|
||||
timestamps <- mapM getModificationTime files
|
||||
let fileTimes = zip files timestamps
|
||||
return $ map fst $ sortBy compareSnd fileTimes
|
||||
|
||||
compareSnd (_,t1) (_,t2) = compare t1 t2
|
||||
|
||||
-- navigates to:
|
||||
-- unpacked/*/.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.8.1.0/build/
|
||||
cleanStackWorkPackages :: IO ()
|
||||
cleanStackWorkPackages =
|
||||
withCurrentDirectory "unpacked" $ do
|
||||
pkgs <- listDirectory "."
|
||||
forM_ pkgs $ \pkg -> do
|
||||
withCurrentDirectory ".stack-work/dist/x86_64-linux-tinfo6"
|
||||
$ withOneDirectory_ -- "Cabal-3.8.1.0"
|
||||
$ withCurrentDirectory "build" $ do
|
||||
ls <- sort <$> listDirectory "."
|
||||
files <- filterM doesFileExist ls
|
||||
let (dynlibs,statlibs) = partition (".so" `isExtensionOf`) files
|
||||
removeOlder removeFile dynlibs
|
||||
removeOlder removeFile statlibs
|
||||
|
||||
withOneDirectory_ act = do
|
||||
ls <- listDirectory "."
|
||||
case ls of
|
||||
[l] -> withCurrentDirectory l act
|
||||
_ -> error $ "more than one directory found: " ++ unwords ls
|
||||
|
||||
withOneDirectory act = do
|
||||
ls <- listDirectory "."
|
||||
case ls of
|
||||
[l] -> withCurrentDirectory l $ act l
|
||||
_ -> error $ "more than one directory found: " ++ unwords ls
|
||||
|
||||
Loading…
Reference in New Issue
Block a user