haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-02-05 11:00:25 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

etc/diskspace: handle more than one pkg work platform dir and warnings

Browse Source 
[skip ci]
This commit is contained in:
Jens Petersen 2023-06-18 00:47:03 +02:00
parent c322900508
commit 3bd98e48e8
1 changed files with 28 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
etc/diskspace/remove-old-stack-work-libs.hs
View File

@ -51,8 +51,8 @@ cleanStackWorkInstall =
extractNameInternal :: String -> String extractNameInternal :: String -> String
extractNameInternal p = extractNameInternal p =
let (name,match,internal) = p =~ "-[0-9.]+-[0-9A-Za-z]{19,22}" :: (String, String, String) 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" in if null match' || null name then error $ p ++ " not in correct name-version-hash format"
else name ++ internal else name ++ internal
samePkgDynLib d1 d2 = pkgDynName d1 == pkgDynName d2 samePkgDynLib d1 d2 = pkgDynName d1 == pkgDynName d2
@ -64,15 +64,18 @@ cleanStackWorkInstall =
removeDashSegment = dropWhileEnd (/= '-') removeDashSegment = dropWhileEnd (/= '-')
removeOlder :: (FilePath -> IO ()) -> [FilePath] -> IO ()
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
timestamps <- mapM getModificationTime files
let fileTimes = zip files timestamps
return $ map fst $ sortBy compareSnd fileTimes
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 compareSnd (_,t1) (_,t2) = compare t1 t2
-- navigates to: -- navigates to:
@ -82,18 +85,24 @@ cleanStackWorkPackages =
withCurrentDirectory "unpacked" $ do withCurrentDirectory "unpacked" $ do
getCurrentDirectory >>= putStrLn getCurrentDirectory >>= putStrLn
pkgs <- listDirectory "." pkgs <- listDirectory "."
forM_ pkgs $ \pkg -> do forM_ pkgs $ \pkg ->
withCurrentDirectory $ pkg </> ".stack-work/dist" withCurrentDirectory (pkg </> ".stack-work/dist") $ do
$ withOneDirectory_ -- "x86_64-linux-tinfo6*" -- [(dyn,stat)]
$ withOneDirectory_ -- "Cabal-*" libs <- do
$ withCurrentDirectory "build" $ do platforms <- listDirectory "." -- "x86_64-linux-tinfo6*"
ls <- sort <$> listDirectory "." forM platforms $ \pl ->
files <- filterM doesFileExist ls withCurrentDirectory pl $
let (dynlibs,others) = partition (".so" `isExtensionOf`) files withOneDirectory_ -- "Cabal-*"
statlibs = filter (".a" `isExtensionOf`) others $ withCurrentDirectory "build" $ do
removeOlder removeFile dynlibs ls <- sort <$> listDirectory "."
removeOlder removeFile statlibs files <- filterM doesFileExist ls
let (dynlibs,others) = partition (".so" `isExtensionOf`) files
statlibs = filter (".a" `isExtensionOf`) others
return (dynlibs,statlibs)
removeOlder removeFile $ concatMap fst libs
removeOlder removeFile $ concatMap snd libs
withOneDirectory_ :: IO a -> IO a
withOneDirectory_ act = do withOneDirectory_ act = do
ls <- listDirectory "." ls <- listDirectory "."
case ls of case ls of
@ -102,6 +111,7 @@ withOneDirectory_ act = do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
error $ "more than one directory found in " ++ cwd ++ ": " ++ unwords ls error $ "more than one directory found in " ++ cwd ++ ": " ++ unwords ls
withOneDirectory :: (FilePath -> IO ()) -> IO ()
withOneDirectory act = do withOneDirectory act = do
ls <- listDirectory "." ls <- listDirectory "."
case ls of case ls of