f6cf2dec4c
Improve disk free space checking when transferring unsized keys to local git remotes. Since the size of the object file is known, can check that instead. Getting unsized keys from local git remotes does not check the actual object size. It would be harder to handle that direction because the size check is run locally, before anything involving the remote is done. So it doesn't know the size of the file on the remote. Also, transferring unsized keys to other remotes, including ssh remotes and p2p remotes don't do disk size checking for unsized keys. This would need a change in protocol. (It does seem like it would be possible to implement the same thing for directory special remotes though.) In some sense, it might be better to not ever do disk free checking for unsized keys, than to do it only sometimes. A user might notice this direction working and consider it a bug that the other direction does not. On the other hand, disk reserve checking is not implemented for most special remotes at all, and yet it is implemented for a few, which is also inconsistent, but best effort. And so doing this best effort seems to make some sense. Fundamentally, if the user wants the size to always be checked, they should not use unsized keys. Sponsored-by: Brock Spratlen on Patreon
137 lines
3.7 KiB
Haskell
137 lines
3.7 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2011-2023 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Command.Reinject where
|
|
|
|
import Command
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import Backend
|
|
import Types.KeySource
|
|
import Utility.Metered
|
|
import Annex.WorkTree
|
|
import qualified Git
|
|
import qualified Annex
|
|
|
|
cmd :: Command
|
|
cmd = withAnnexOptions [backendOption, jsonOptions] $
|
|
command "reinject" SectionUtility
|
|
"inject content of file back into annex"
|
|
(paramRepeating (paramPair "SRC" "DEST"))
|
|
(seek <$$> optParser)
|
|
|
|
data ReinjectOptions = ReinjectOptions
|
|
{ params :: CmdParams
|
|
, knownOpt :: Bool
|
|
, guessKeysOpt :: Bool
|
|
}
|
|
|
|
optParser :: CmdParamsDesc -> Parser ReinjectOptions
|
|
optParser desc = ReinjectOptions
|
|
<$> cmdParams desc
|
|
<*> switch
|
|
( long "known"
|
|
<> help "inject all known files"
|
|
<> hidden
|
|
)
|
|
<*> switch
|
|
( long "guesskeys"
|
|
<> help "inject files that are named like keys"
|
|
<> hidden
|
|
)
|
|
|
|
seek :: ReinjectOptions -> CommandSeek
|
|
seek os
|
|
| guessKeysOpt os && knownOpt os = giveup "Cannot combine --known with --guesskeys"
|
|
| guessKeysOpt os = withStrings (commandAction . startGuessKeys) (params os)
|
|
| knownOpt os = withStrings (commandAction . startKnown) (params os)
|
|
| otherwise = withPairs (commandAction . startSrcDest) (params os)
|
|
|
|
startSrcDest :: (SeekInput, (String, String)) -> CommandStart
|
|
startSrcDest (si, (src, dest))
|
|
| src == dest = stop
|
|
| otherwise = starting "reinject" ai si $ notAnnexed src' $
|
|
lookupKey (toRawFilePath dest) >>= \case
|
|
Just key -> ifM (verifyKeyContent key src')
|
|
( perform src' key
|
|
, do
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
giveup $ decodeBS $ quote qp $ QuotedPath src'
|
|
<> " does not have expected content of "
|
|
<> QuotedPath (toRawFilePath dest)
|
|
)
|
|
Nothing -> do
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
giveup $ decodeBS $ quote qp $ QuotedPath src'
|
|
<> " is not an annexed file"
|
|
where
|
|
src' = toRawFilePath src
|
|
ai = ActionItemOther (Just (QuotedPath src'))
|
|
|
|
startGuessKeys :: FilePath -> CommandStart
|
|
startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $
|
|
case fileKey (toRawFilePath (takeFileName src)) of
|
|
Just key -> ifM (verifyKeyContent key src')
|
|
( perform src' key
|
|
, do
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
giveup $ decodeBS $ quote qp $ QuotedPath src'
|
|
<> " does not have expected content"
|
|
)
|
|
Nothing -> do
|
|
warning "Not named like an object file; skipping"
|
|
next $ return True
|
|
where
|
|
src' = toRawFilePath src
|
|
ai = ActionItemOther (Just (QuotedPath src'))
|
|
si = SeekInput [src]
|
|
|
|
startKnown :: FilePath -> CommandStart
|
|
startKnown src = starting "reinject" ai si $ notAnnexed src' $ do
|
|
(key, _) <- genKey ks nullMeterUpdate =<< defaultBackend
|
|
ifM (isKnownKey key)
|
|
( perform src' key
|
|
, do
|
|
warning "Not known content; skipping"
|
|
next $ return True
|
|
)
|
|
where
|
|
src' = toRawFilePath src
|
|
ks = KeySource src' src' Nothing
|
|
ai = ActionItemOther (Just (QuotedPath src'))
|
|
si = SeekInput [src]
|
|
|
|
notAnnexed :: RawFilePath -> CommandPerform -> CommandPerform
|
|
notAnnexed src a =
|
|
ifM (fromRepo Git.repoIsLocalBare)
|
|
( a
|
|
, lookupKey src >>= \case
|
|
Just _ -> do
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
giveup $ decodeBS $ quote qp $
|
|
"cannot used annexed file as src: "
|
|
<> QuotedPath src
|
|
Nothing -> a
|
|
)
|
|
|
|
perform :: RawFilePath -> Key -> CommandPerform
|
|
perform src key = do
|
|
maybeAddJSONField "key" (serializeKey key)
|
|
ifM move
|
|
( next $ cleanup key
|
|
, giveup "failed"
|
|
)
|
|
where
|
|
move = checkDiskSpaceToGet key Nothing False $
|
|
moveAnnex key (AssociatedFile Nothing) src
|
|
|
|
cleanup :: Key -> CommandCleanup
|
|
cleanup key = do
|
|
logStatus key InfoPresent
|
|
return True
|