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: haskell#7842

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 =

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.
+--
+-- <cabal_dir>/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 <cabal_dir>/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