cabal-install/src/Distribution/Client/CmdClean.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3
   4 module Distribution.Client.CmdClean (cleanCommand, cleanAction) where
   5
   6 import Distribution.Client.Compat.Prelude
   7 import Prelude ()
   8
   9 import Distribution.Client.Config
  10   ( defaultScriptBuildsDir
  11   )
  12 import Distribution.Client.DistDirLayout
  13   ( DistDirLayout (..)
  14   , defaultDistDirLayout
  15   )
  16 import Distribution.Client.Errors
  17 import Distribution.Client.ProjectConfig
  18   ( findProjectRoot
  19   )
  20 import Distribution.Client.ProjectFlags
  21   ( ProjectFlags (..)
  22   , defaultProjectFlags
  23   , projectFlagsOptions
  24   , removeIgnoreProjectOption
  25   )
  26 import Distribution.Client.Setup
  27   ( GlobalFlags
  28   )
  29 import Distribution.Compat.Lens
  30   ( _1
  31   , _2
  32   )
  33 import Distribution.Simple.Command
  34   ( CommandUI (..)
  35   , OptionField
  36   , ShowOrParseArgs
  37   , liftOptionL
  38   , option
  39   )
  40 import Distribution.Simple.Setup
  41   ( Flag (..)
  42   , falseArg
  43   , flagToMaybe
  44   , fromFlagOrDefault
  45   , optionDistPref
  46   , optionVerbosity
  47   , toFlag
  48   )
  49 import Distribution.Simple.Utils
  50   ( dieWithException
  51   , handleDoesNotExist
  52   , info
  53   , wrapText
  54   )
  55 import Distribution.System
  56   ( OS (Windows)
  57   , buildOS
  58   )
  59 import Distribution.Utils.Path hiding
  60   ( (<.>)
  61   , (</>)
  62   )
  63 import Distribution.Verbosity
  64   ( normal
  65   )
  66
  67 import Control.Exception
  68   ( throw
  69   )
  70 import Control.Monad
  71   ( forM
  72   , forM_
  73   , mapM
  74   )
  75 import qualified Data.Set as Set
  76 import System.Directory
  77   ( canonicalizePath
  78   , doesDirectoryExist
  79   , doesFileExist
  80   , getDirectoryContents
  81   , listDirectory
  82   , removeDirectoryRecursive
  83   , removeFile
  84   , removePathForcibly
  85   )
  86 import System.FilePath
  87   ( (</>)
  88   )
  89 import System.IO.Error
  90   ( isPermissionError
  91   )
  92 import qualified System.Process as Process
  93
  94 data CleanFlags = CleanFlags
  95   { cleanSaveConfig :: Flag Bool
  96   , cleanVerbosity :: Flag Verbosity
  97   , cleanDistDir :: Flag (SymbolicPath Pkg (Dir Dist))
  98   }
  99   deriving (Eq)
 100
 101 defaultCleanFlags :: CleanFlags
 102 defaultCleanFlags =
 103   CleanFlags
 104     { cleanSaveConfig = toFlag False
 105     , cleanVerbosity = toFlag normal
 106     , cleanDistDir = NoFlag
 107     }
 108
 109 cleanCommand :: CommandUI (ProjectFlags, CleanFlags)
 110 cleanCommand =
 111   CommandUI
 112     { commandName = "v2-clean"
 113     , commandSynopsis = "Clean the package store and remove temporary files."
 114     , commandUsage = \pname ->
 115         "Usage: " ++ pname ++ " new-clean [FLAGS]\n"
 116     , commandDescription = Just $ \_ ->
 117         wrapText $
 118           "Removes all temporary files created during the building process "
 119             ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "
 120             ++ "local caches (by default).\n\n"
 121     , commandNotes = Nothing
 122     , commandDefaultFlags = (defaultProjectFlags, defaultCleanFlags)
 123     , commandOptions = \showOrParseArgs ->
 124         map
 125           (liftOptionL _1)
 126           (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs))
 127           ++ map (liftOptionL _2) (cleanOptions showOrParseArgs)
 128     }
 129
 130 cleanOptions :: ShowOrParseArgs -> [OptionField CleanFlags]
 131 cleanOptions showOrParseArgs =
 132   [ optionVerbosity
 133       cleanVerbosity
 134       (\v flags -> flags{cleanVerbosity = v})
 135   , optionDistPref
 136       cleanDistDir
 137       (\dd flags -> flags{cleanDistDir = dd})
 138       showOrParseArgs
 139   , option
 140       ['s']
 141       ["save-config"]
 142       "Save configuration, only remove build artifacts"
 143       cleanSaveConfig
 144       (\sc flags -> flags{cleanSaveConfig = sc})
 145       falseArg
 146   ]
 147
 148 cleanAction :: (ProjectFlags, CleanFlags) -> [String] -> GlobalFlags -> IO ()
 149 cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do
 150   let verbosity = fromFlagOrDefault normal cleanVerbosity
 151       saveConfig = fromFlagOrDefault False cleanSaveConfig
 152       mdistDirectory = fmap getSymbolicPath $ flagToMaybe cleanDistDir
 153       mprojectDir = flagToMaybe flagProjectDir
 154       mprojectFile = flagToMaybe flagProjectFile
 155
 156   -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
 157   --
 158   -- For now assume all files passed are the names of scripts
 159   notScripts <- filterM (fmap not . doesFileExist) extraArgs
 160   unless (null notScripts) $
 161     dieWithException verbosity $
 162       CleanAction notScripts
 163
 164   projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
 165
 166   let distLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
 167
 168   -- Do not clean a project if just running a script in it's directory
 169   when (null extraArgs || isJust mdistDirectory) $ do
 170     if saveConfig
 171       then do
 172         let buildRoot = distBuildRootDirectory distLayout
 173
 174         buildRootExists <- doesDirectoryExist buildRoot
 175
 176         when buildRootExists $ do
 177           info verbosity ("Deleting build root (" ++ buildRoot ++ ")")
 178           handleDoesNotExist () $ removeDirectoryRecursive buildRoot
 179       else do
 180         let distRoot = distDirectory distLayout
 181
 182         info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
 183         handleDoesNotExist () $ do
 184           if buildOS == Windows
 185             then do
 186               -- Windows can't delete some git files #10182
 187               void $
 188                 Process.createProcess_ "attrib" $
 189                   Process.shell $
 190                     "attrib -s -h -r " <> distRoot <> "\\*.* /s /d"
 191               catch
 192                 (removePathForcibly distRoot)
 193                 (\e -> if isPermissionError e then removePathForcibly distRoot else throw e)
 194             else removeDirectoryRecursive distRoot
 195
 196     removeEnvFiles $ distProjectRootDirectory distLayout
 197
 198   -- Clean specified script build caches and orphaned caches.
 199   -- There is currently no good way to specify to only clean orphaned caches.
 200   -- It would be better as part of an explicit gc step (see issue #3333)
 201   toClean <- Set.fromList <$> mapM canonicalizePath extraArgs
 202   cacheDir <- defaultScriptBuildsDir
 203   existsCD <- doesDirectoryExist cacheDir
 204   caches <- if existsCD then listDirectory cacheDir else return []
 205   paths <- fmap concat . forM caches $ \cache -> do
 206     let locFile = cacheDir </> cache </> "scriptlocation"
 207     exists <- doesFileExist locFile
 208     if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []
 209   forM_ paths $ \(cache, script) -> do
 210     exists <- doesFileExist script
 211     when (not exists || script `Set.member` toClean) $ do
 212       info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")
 213       removeDirectoryRecursive cache
 214
 215 removeEnvFiles :: FilePath -> IO ()
 216 removeEnvFiles dir =
 217   (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))
 218     =<< getDirectoryContents dir