From 04ee14c76942cd27c29dd28d3d28b84b4570cbb7 Mon Sep 17 00:00:00 2001
From: Jens Petersen <juhpetersen@gmail.com>
Date: Sat, 17 Jun 2023 23:55:30 +0200
Subject: [PATCH] etc/diskspace: extend to also clean unpacked .stack-work
 builds

[skip ci]
---
 etc/diskspace/remove-old-stack-work-libs.hs | 59 ++++++++++++++++++---
 1 file changed, 52 insertions(+), 7 deletions(-)

diff --git a/etc/diskspace/remove-old-stack-work-libs.hs b/etc/diskspace/remove-old-stack-work-libs.hs
index eb469ee1..5932188f 100644
--- a/etc/diskspace/remove-old-stack-work-libs.hs
+++ b/etc/diskspace/remove-old-stack-work-libs.hs
@@ -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