From 3062e5a42609af7250f619a4a890710eed310911 Mon Sep 17 00:00:00 2001 From: Mel Zuser Date: Wed, 1 Dec 2021 23:15:22 -0500 Subject: [PATCH] Add script support to cabal clean. This changes the behaviour of cabal clean to accept extra args, which it now interprets as script files. The behaviour of cabal clean is the same when given extra args. When given extra args it instead removes the caches for those scripts and also any orphaned caches (caches for which the script no longer exists) In addition this commit changes the cache to use hashes of paths because this significantly simplifies the implementation of clean, and more importantly it prevents collisions when a script has the name of the subdirectory of a previously cached script. WIP: #7842 --- .../src/Distribution/Client/CmdClean.hs | 40 ++++++++++++++----- .../src/Distribution/Client/ScriptUtils.hs | 30 ++++++++++---- 2 files changed, 53 insertions(+), 17 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs index 956552b3f06..aea3661e6e2 100644 --- a/cabal-install/src/Distribution/Client/CmdClean.hs +++ b/cabal-install/src/Distribution/Client/CmdClean.hs @@ -8,6 +8,8 @@ import Distribution.Client.DistDirLayout ( DistDirLayout(..), defaultDistDirLayout ) import Distribution.Client.ProjectConfig ( findProjectRoot ) +import Distribution.Client.ScriptUtils + ( getScriptCacheDirectoryRoot ) import Distribution.Client.Setup ( GlobalFlags ) import Distribution.ReadE ( succeedReadE ) @@ -22,9 +24,14 @@ import Distribution.Simple.Utils import Distribution.Verbosity ( normal ) +import Control.Monad + ( forM, forM_, mapM ) +import qualified Data.Set as Set import System.Directory ( removeDirectoryRecursive, removeFile - , doesDirectoryExist, getDirectoryContents ) + , doesDirectoryExist, doesFileExist + , getDirectoryContents, listDirectory + , canonicalizePath ) import System.FilePath ( () ) @@ -80,16 +87,18 @@ cleanAction CleanFlags{..} extraArgs _ = do mdistDirectory = flagToMaybe cleanDistDir mprojectFile = flagToMaybe cleanProjectFile - unless (null extraArgs) $ - die' verbosity $ "'clean' doesn't take any extra arguments: " - ++ unwords extraArgs + -- assume all files passed are the names of scripts + notScripts <- filterM (fmap not . doesFileExist) extraArgs + unless (null notScripts) $ + die' verbosity $ "'clean' extra arguments should be script files: " + ++ unwords notScripts - projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + if null extraArgs then do + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile - let distLayout = defaultDistDirLayout projectRoot mdistDirectory + let distLayout = defaultDistDirLayout projectRoot mdistDirectory - if saveConfig - then do + if saveConfig then do let buildRoot = distBuildRootDirectory distLayout buildRootExists <- doesDirectoryExist buildRoot @@ -103,7 +112,20 @@ cleanAction CleanFlags{..} extraArgs _ = do info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive distRoot - removeEnvFiles (distProjectRootDirectory distLayout) + removeEnvFiles (distProjectRootDirectory distLayout) + else do + -- when cleaning script builds, also clean orphaned caches + toClean <- Set.fromList <$> mapM canonicalizePath extraArgs + cacheDir <- getScriptCacheDirectoryRoot + caches <- listDirectory cacheDir + paths <- fmap concat . forM caches $ \cache -> do + let locFile = cacheDir cache "scriptlocation" + exists <- doesFileExist locFile + if exists then pure . (,) (cacheDir cache) <$> readFile locFile else return [] + forM_ paths $ \(cache, script) -> do + exists <- doesFileExist script + unless (exists && script `Set.notMember` toClean) $ do + removeDirectoryRecursive cache removeEnvFiles :: FilePath -> IO () removeEnvFiles dir = diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 153c8f922f5..42e00a605d2 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -6,7 +6,7 @@ -- | Utilities to help commands with scripts -- module Distribution.Client.ScriptUtils ( - getScriptCacheDirectory, + getScriptCacheDirectoryRoot, getScriptCacheDirectory, withTempTempDirectory, getContextAndSelectorsWithScripts ) where @@ -65,25 +65,37 @@ import Distribution.Types.PackageName.Magic ( fakePackageId ) import Language.Haskell.Extension ( Language(..) ) +import Distribution.Client.HashValue + ( hashValue, showHashValue ) import Control.Exception - ( bracket ) + ( bracket ) import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Lazy () import qualified Text.Parsec as P import System.Directory - ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist, makeAbsolute ) + ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist, canonicalizePath ) import System.FilePath ( (), takeExtension ) + +-- | Get the directory where script builds are cached. +-- +-- /script-builds +getScriptCacheDirectoryRoot :: IO FilePath +getScriptCacheDirectoryRoot = do + cabalDir <- getCabalDir + return $ cabalDir "script-builds" + -- | Get the directory for caching a script build. -- -- The only identity of a script is it's absolute path, so append that path -- to /script-builds/ to get the cache directory. getScriptCacheDirectory :: FilePath -> IO FilePath getScriptCacheDirectory script = do - scriptAbs <- dropWhile (\c -> c == '/' || c == '\\') <$> makeAbsolute script - cabalDir <- getCabalDir - return $ cabalDir "script-builds" scriptAbs + cacheDir <- getScriptCacheDirectoryRoot + scriptHash <- showHashValue . hashValue . fromString <$> canonicalizePath script + return $ cacheDir scriptHash -- | Create a new temporary directory inside the directory for temporary files -- and delete it after use. @@ -117,7 +129,7 @@ getContextAndSelectorsWithScripts flags@NixStyleFlags {..} targetStrings globalF then do cacheDir <- getScriptCacheDirectory script ctx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without cacheDir) - BS.readFile script >>= handleScriptCase verbosity pol ctx cacheDir + BS.readFile script >>= handleScriptCase verbosity pol ctx cacheDir script else reportTargetSelectorProblems verbosity err -- We pass the baseCtx made with tmpDir to readTargetSelectors and only create a ctx with cacheDir @@ -206,9 +218,10 @@ handleScriptCase -> PlainOrLiterate -> ProjectBaseContext -> FilePath + -> FilePath -> BS.ByteString -> IO (ProjectBaseContext, [TargetSelector]) -handleScriptCase verbosity pol baseCtx dir scriptContents = do +handleScriptCase verbosity pol baseCtx dir scriptPath scriptContents = do (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents -- We need to create a dummy package that lives in our dummy project. @@ -245,6 +258,7 @@ handleScriptCase verbosity pol baseCtx dir scriptContents = do pkgId = fakePackageId writeGenericPackageDescription (dir "fake-package.cabal") genericPackageDescription + writeFile (dir "scriptlocation") =<< canonicalizePath scriptPath BS.writeFile (dir mainName) contents' let