{-# LANGUAGE FlexibleContexts #-}
module Package.C.Db.GarbageCollect ( cleanSymlinks
, cleanCache
, garbageCollect
) where
import Control.Monad.Reader (MonadReader)
import CPkgPrelude
import qualified Data.Set as S
import qualified Data.Text as T
import Package.C.Db.Memory (globalPkgDir)
import Package.C.Db.Monad (MonadDb)
import Package.C.Db.Register
import Package.C.Db.Type
import Package.C.Logging (putDiagnostic)
import Package.C.Type (TargetTriple, Verbosity)
import System.Directory (doesDirectoryExist, doesFileExist, getSymbolicLinkTarget, listDirectory, removeDirectoryRecursive, removeFile)
import System.FilePath ((</>))
getTransitiveDepsByName :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m (S.Set BuildCfg)
getTransitiveDepsByName = getTransitiveDeps <=*< lookupOrFail
garbageCollect :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
=> m ()
garbageCollect = garbageCollectPkgs *> cleanSymlinks
garbageCollectPkgs :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
=> m ()
garbageCollectPkgs = do
allPkgs <- installedDb
let manuals = (toList . S.filter manual) allPkgs
putDiagnostic ("Manually installed packages: " ++ show (buildName <$> manuals))
allDeps <- S.unions <$> traverse getTransitiveDeps manuals
let redundant = allPkgs S.\\ allDeps
putDiagnostic ("Redundant packages: " ++ show (buildName <$> toList redundant))
traverse_ uninstallPkg redundant
getTransitiveDeps :: (MonadIO m, MonadDb m) => BuildCfg -> m (S.Set BuildCfg)
getTransitiveDeps cfg = do
let names = fst <$> pinnedDeps cfg
host = targetArch cfg
next <- traverse (\n -> getTransitiveDepsByName n host) (T.unpack <$> names)
pure $ S.insert cfg (S.unions next)
cleanCache :: MonadIO m => m ()
cleanCache = liftIO $ do
ccDir <- (</> "cache") <$> globalPkgDir
exists <- doesDirectoryExist ccDir
when exists $
removeDirectoryRecursive ccDir
cleanSymlinks :: (MonadReader Verbosity m, MonadIO m) => m ()
cleanSymlinks = do
pkDir <- liftIO globalPkgDir
let binDir = pkDir </> "bin"
manDir = pkDir </> "share" </> "man"
man1Dir = manDir </> "man1"
man3Dir = manDir </> "man3"
traverse_ cleanDir
[binDir, man1Dir, man3Dir]
cleanDir :: (MonadReader Verbosity m, MonadIO m) => FilePath -> m ()
cleanDir dir = do
exists <- liftIO $ doesDirectoryExist dir
when exists $ do
links <- liftIO $ listDirectory dir
forM_ links $ \link -> do
let linkAbs = dir </> link
brk <- liftIO $ isBroken linkAbs
when brk $
putDiagnostic ("Removing link " ++ linkAbs ++ "...") *>
liftIO (removeFile linkAbs)
isBroken :: FilePath -> IO Bool
isBroken = (fmap not . doesFileExist) <=< getSymbolicLinkTarget