git-annex/Command/DropUnused.hs
Joey Hess c3d40b9ec3
plumb in LiveUpdate (WIP)
Each command that first checks preferred content (and/or required
content) and then does something that can change the sizes of
repositories needs to call prepareLiveUpdate, and plumb it through the
preferred content check and the location log update.

So far, only Command.Drop is done. Many other commands that don't need
to do this have been updated to keep working.

There may be some calls to NoLiveUpdate in places where that should be
done. All will need to be double checked.

Not currently in a compilable state.
2024-08-23 16:35:12 -04:00

84 lines
2.6 KiB
Haskell

{- git-annex command
-
- Copyright 2010,2012,2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Command.DropUnused where
import Command
import qualified Annex
import qualified Command.Drop
import qualified Remote
import qualified Git
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Annex.NumCopies
import Annex.Content
import qualified Utility.RawFilePath as R
cmd :: Command
cmd = withAnnexOptions [jobsOption, jsonOptions] $
command "dropunused" SectionMaintenance
"drop unused file content"
(paramRepeating paramNumRange) (seek <$$> optParser)
data DropUnusedOptions = DropUnusedOptions
{ rangesToDrop :: CmdParams
, dropFrom :: Maybe (DeferredParse Remote)
}
optParser :: CmdParamsDesc -> Parser DropUnusedOptions
optParser desc = DropUnusedOptions
<$> cmdParams desc
<*> optional (Command.Drop.parseDropFromOption)
seek :: DropUnusedOptions -> CommandSeek
seek o = startConcurrency commandStages $ do
numcopies <- getNumCopies
mincopies <- getMinCopies
from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o)
withUnusedMaps (start from numcopies mincopies) (rangesToDrop o)
start :: Maybe Remote -> NumCopies -> MinCopies -> UnusedMaps -> Int -> CommandStart
start from numcopies mincopies = startUnused
(go (perform from numcopies mincopies))
(go (performOther gitAnnexBadLocation))
(go (performOther gitAnnexTmpObjectLocation))
where
go a n key = starting "dropunused"
(ActionItemOther $ Just $ UnquotedString $ show n)
(SeekInput [show n])
(a key)
perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform
perform from numcopies mincopies key = case from of
Just r -> do
showAction $ UnquotedString $ "from " ++ Remote.name r
Command.Drop.performRemote NoLiveUpdate pcc key
(AssociatedFile Nothing) numcopies mincopies r ud
Nothing -> ifM (inAnnex key)
( droplocal
, ifM (objectFileExists key)
( ifM (Annex.getRead Annex.force)
( droplocal
, do
warning "Annexed object has been modified and dropping it would probably lose the only copy. Run this command with --force if you want to drop it anyway."
next $ return False
)
, next $ return True
)
)
where
droplocal = Command.Drop.performLocal NoLiveUpdate pcc
key (AssociatedFile Nothing) numcopies mincopies [] ud
pcc = Command.Drop.PreferredContentChecked False
ud = Command.Drop.DroppingUnused True
performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform
performOther filespec key = do
f <- fromRepo $ filespec key
pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith R.removeLink)
next $ return True