git-annex/Command/Get.hs
Joey Hess b55efc179a
add startAction parameter for KeySha
I have a use planned for this in Command.Migrate.

Sponsored-by: unqueued on Patreon
2023-12-06 13:28:02 -04:00

122 lines
3.9 KiB
Haskell

{- git-annex command
-
- Copyright 2010-2023 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Command.Get where
import Command
import qualified Remote
import Annex.Transfer
import Annex.NumCopies
import Annex.Wanted
import qualified Command.Move
import Logs.Location
cmd :: Command
cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $
command "get" SectionCommon
"make content of annexed files available"
paramPaths (seek <$$> optParser)
data GetOptions = GetOptions
{ getFiles :: CmdParams
, getFrom :: Maybe (DeferredParse Remote)
, autoMode :: Bool
, keyOptions :: Maybe KeyOptions
, batchOption :: BatchMode
}
optParser :: CmdParamsDesc -> Parser GetOptions
optParser desc = GetOptions
<$> cmdParams desc
<*> optional (mkParseRemoteOption <$> parseFromOption)
<*> parseAutoOption
<*> optional (parseIncompleteOption <|> parseKeyOptions <|> parseFailedTransfersOption)
<*> parseBatchOption True
seek :: GetOptions -> CommandSeek
seek o = startConcurrency transferStages $ do
from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
let seeker = AnnexedFileSeeker
{ startAction = const $ start o from
, checkContentPresent = Just False
, usesLocationLog = True
}
case batchOption o of
NoBatch -> withKeyOptions (keyOptions o) (autoMode o) seeker
(commandAction . startKeys from)
(withFilesInGitAnnex ww seeker)
=<< workTreeItems ww (getFiles o)
Batch fmt -> batchOnly (keyOptions o) (getFiles o) $
batchAnnexed fmt seeker (startKeys from)
where
ww = WarnUnmatchLsFiles "get"
start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
start o from si file key = start' expensivecheck from key afile ai si
where
afile = AssociatedFile (Just file)
ai = mkActionItem (key, afile)
expensivecheck
| autoMode o = numCopiesCheck file key (<)
<||> wantGet False (Just key) afile
| otherwise = return True
startKeys :: Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart
startKeys from (si, key, ai) = checkFailedTransferDirection ai Download $
start' (return True) from key (AssociatedFile Nothing) ai si
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart
start' expensivecheck from key afile ai si =
stopUnless expensivecheck $
case from of
Nothing -> go $ perform key afile
Just src ->
stopUnless (Command.Move.fromOk src key) $
go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile
where
go = starting "get" (OnlyActionOn key ai) si
perform :: Key -> AssociatedFile -> CommandPerform
perform key afile = stopUnless (getKey key afile) $
next $ return True -- no cleanup needed
{- Try to find a copy of the file in one of the remotes,
- and copy it to here. -}
getKey :: Key -> AssociatedFile -> Annex Bool
getKey key afile = getKey' key afile
=<< Remote.keyPossibilities (Remote.IncludeIgnored False) key
getKey' :: Key -> AssociatedFile -> [Remote] -> Annex Bool
getKey' key afile = dispatch
where
dispatch [] = do
showNote (UnquotedString "not available")
showlocs []
return False
dispatch remotes = notifyTransfer Download afile $ \witness -> do
ok <- pickRemote remotes $ \r -> ifM (probablyPresent r)
( docopy r witness
, return False
)
if ok
then return ok
else do
Remote.showTriedRemotes remotes
showlocs (map Remote.uuid remotes)
return False
showlocs exclude = Remote.showLocations False key exclude
"No other repository is known to contain the file."
-- This check is to avoid an ugly message if a remote is a
-- drive that is not mounted.
probablyPresent r
| Remote.hasKeyCheap r =
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
docopy r witness = do
showAction $ UnquotedString $ "from " ++ Remote.name r
logStatusAfter key $
download r key afile stdRetry witness