stackage/etc/diskspace/remove-old-stack-work-libs.hs

#!/usr/bin/env stack
-- stack --resolver lts-19.33 script

-- Utility to remove old libs installed under .stack-work/ to save diskspace

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
        putStrLn ""
        cleanStackWorkPackages
    _ -> error "arg should be 'lts-XX' 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
  getCurrentDirectory >>= putStrLn
  files <- sort <$> listDirectory "."
  let (dynlibs,libdirs) = partition (".so" `isExtensionOf`) files
      pkglibdirs = groupBy samePkgLibDir libdirs
      pkgdynlibs = groupBy samePkgDynLib dynlibs
  mapM_ (removeOlder removeDirectoryRecursive) pkglibdirs
  mapM_ (removeOlder removeFile) pkgdynlibs
  where
    samePkgLibDir l1 l2 = pkgDirName l1 == pkgDirName l2
      where
        pkgDirName p =
          if length p < 25
          then error $ p ++ " too short to be in correct name-version-hash format"
          else extractNameInternal p

    extractNameInternal :: String -> String
    extractNameInternal p =
      let (name,match',internal) = p =~ "-[0-9.]+-[0-9A-Za-z]{19,22}" :: (String, String, String)
      in if null match' || null name then error $ p ++ " not in correct name-version-hash format"
         else name ++ internal

    samePkgDynLib d1 d2 = pkgDynName d1 == pkgDynName d2
      where
        pkgDynName p =
          if length p < 42
          then error $ p ++ " too short to be libHSname-version-hash-ghc*.so format"
          else (extractNameInternal . removeDashSegment) p

    removeDashSegment = dropWhileEnd (/= '-')


removeOlder :: (FilePath -> IO ()) -> [FilePath] -> IO ()
removeOlder remover files = do
  oldfiles <- drop keepBuilds . reverse <$> sortByAge files
  mapM_ remover oldfiles

sortByAge :: [FilePath] -> IO [FilePath]
sortByAge files = do
  timestamps <- mapM getModificationTime files
  let fileTimes = zip files timestamps
  return $ map fst $ sortBy compareSnd fileTimes
  where
    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
  getCurrentDirectory >>= putStrLn
  pkgs <- listDirectory "."
  forM_ pkgs $ \pkg ->
    withCurrentDirectory (pkg </> ".stack-work/dist") $ do
    -- [(dyn,stat)]
    libs <- do
      platforms <- listDirectory "." -- "x86_64-linux-tinfo6*"
      forM platforms $ \pl ->
        withCurrentDirectory pl $
        withOneDirectory -- "Cabal-*"
        $ \cbl ->
        withCurrentDirectory "build" $ do
        ls <- sort <$> listDirectory "."
        files <- filterM doesFileExist ls
        let (dynlibs,others) = partition (".so" `isExtensionOf`) files
            statlibs = filter (".a" `isExtensionOf`) others
        let dir = pl </> cbl </> "build"
        return (map (dir </>) dynlibs, map (dir </>) statlibs)
    removeOlder removeFile $ concatMap fst libs
    removeOlder removeFile $ concatMap snd libs

withOneDirectory_ :: IO a -> IO a
withOneDirectory_ act = do
  ls <- listDirectory "."
  case ls of
    [l] -> withCurrentDirectory l act
    _ -> do
      cwd <- getCurrentDirectory
      error $ show (length ls) ++ " directories found in " ++ cwd ++ ": " ++ unwords ls

withOneDirectory :: (FilePath -> IO a) -> IO a
withOneDirectory act = do
  ls <- listDirectory "."
  case ls of
    [l] -> withCurrentDirectory l $ act l
    _ -> do
      cwd <- getCurrentDirectory
      error $ show (length ls) ++ " directories found in " ++ cwd ++ ": " ++ unwords ls