mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-31 00:20:26 +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
|
-- Utility to remove old libs installed under .stack-work/ to save diskspace
|
||||||
|
|
||||||
-- Should be run in:
|
import Control.Monad
|
||||||
-- work/*/unpack-dir/.stack-work/install/x86_64-linux/*/*/lib/x86_64-linux-ghc-*
|
|
||||||
|
|
||||||
import Data.List
|
import Data.List
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
import System.Environment
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
-- keep 2 latest builds
|
-- keep 2 latest builds
|
||||||
keepBuilds :: Int
|
keepBuilds :: Int
|
||||||
keepBuilds = 2
|
keepBuilds = 2
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
main = do
|
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 "."
|
files <- sort <$> listDirectory "."
|
||||||
let (dynlibs,libdirs) = partition (".so" `isExtensionOf`) files
|
let (dynlibs,libdirs) = partition (".so" `isExtensionOf`) files
|
||||||
pkglibdirs = groupBy samePkgLibDir libdirs
|
pkglibdirs = groupBy samePkgLibDir libdirs
|
||||||
@ -45,13 +62,41 @@ main = do
|
|||||||
|
|
||||||
removeDashSegment = dropWhileEnd (/= '-')
|
removeDashSegment = dropWhileEnd (/= '-')
|
||||||
|
|
||||||
removeOlder remover files = do
|
removeOlder remover files = do
|
||||||
oldfiles <- drop keepBuilds . reverse <$> sortByAge files
|
oldfiles <- drop keepBuilds . reverse <$> sortByAge files
|
||||||
mapM_ remover oldfiles
|
mapM_ remover oldfiles
|
||||||
|
where
|
||||||
sortByAge files = do
|
sortByAge files = do
|
||||||
timestamps <- mapM getModificationTime files
|
timestamps <- mapM getModificationTime files
|
||||||
let fileTimes = zip files timestamps
|
let fileTimes = zip files timestamps
|
||||||
return $ map fst $ sortBy compareSnd fileTimes
|
return $ map fst $ sortBy compareSnd fileTimes
|
||||||
|
|
||||||
compareSnd (_,t1) (_,t2) = compare t1 t2
|
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