remove "checking remotename" message

This fixes fsck of a remote that uses chunking displaying
(checking remotename) (checking remotename)" for every chunk.

Also, some remotes displayed the message, and others did not, with no
consistency. It was originally displayed only when accessing remotes
that were expensive or might involve a password prompt, I think, but
nothing in the API said when to do it so it became an inconsistent mess.

Originally I thought fsck should always display it. But it only displays
in fsck --from remote, so the user knows the remote is being accessed,
so there is no reason to tell them it's accessing it over and over.

It was also possible for git-annex move to sometimes display it twice,
due to checking if content is present twice. But, the user of move
specifies --from/--to, so it does not need to display when it's
accessing the remote, as the user expects it to access the remote.

git-annex get might display it, but only if the remote also supports
hasKeyCheap, which is really only local git remotes, which didn't
display it always; and in any case nothing displayed it before hasKeyCheap,
which is checked first, so I don't think this needs to display it ever.

mirror is like move. And that's all the main places it would have been
displayed.

This commit was sponsored by Jochen Bartl on Patreon.
This commit is contained in:
Joey Hess 2021-04-27 12:50:45 -04:00
parent f58fb5a610
commit f8836306fa
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
14 changed files with 36 additions and 66 deletions

View file

@ -15,7 +15,6 @@ import Types.Import
import qualified Git import qualified Git
import Config.Cost import Config.Cost
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Annex.UUID import Annex.UUID
import Utility.Metered import Utility.Metered
@ -77,7 +76,7 @@ gen r u rc gc rs = do
, retrieveExport = retrieveExportM serial adir , retrieveExport = retrieveExportM serial adir
, removeExport = removeExportM serial adir , removeExport = removeExportM serial adir
, versionedExport = False , versionedExport = False
, checkPresentExport = checkPresentExportM this serial adir , checkPresentExport = checkPresentExportM serial adir
, removeExportDirectory = Just $ removeExportDirectoryM serial adir , removeExportDirectory = Just $ removeExportDirectoryM serial adir
, renameExport = renameExportM serial adir , renameExport = renameExportM serial adir
} }
@ -115,7 +114,7 @@ gen r u rc gc rs = do
(store serial adir) (store serial adir)
(retrieve serial adir) (retrieve serial adir)
(remove serial adir) (remove serial adir)
(checkKey this serial adir) (checkKey serial adir)
this this
where where
adir = maybe (giveup "missing androiddirectory") AndroidPath adir = maybe (giveup "missing androiddirectory") AndroidPath
@ -214,12 +213,11 @@ remove' :: AndroidSerial -> AndroidPath -> Annex Bool
remove' serial aloc = adbShellBool serial remove' serial aloc = adbShellBool serial
[Param "rm", Param "-f", File (fromAndroidPath aloc)] [Param "rm", Param "-f", File (fromAndroidPath aloc)]
checkKey :: Remote -> AndroidSerial -> AndroidPath -> CheckPresent checkKey :: AndroidSerial -> AndroidPath -> CheckPresent
checkKey r serial adir k = checkKey' r serial (androidLocation adir k) checkKey serial adir k = checkKey' serial (androidLocation adir k)
checkKey' :: Remote -> AndroidSerial -> AndroidPath -> Annex Bool checkKey' :: AndroidSerial -> AndroidPath -> Annex Bool
checkKey' r serial aloc = do checkKey' serial aloc = do
showChecking r
out <- adbShellRaw serial $ unwords out <- adbShellRaw serial $ unwords
[ "if test -e ", shellEscape (fromAndroidPath aloc) [ "if test -e ", shellEscape (fromAndroidPath aloc)
, "; then echo y" , "; then echo y"
@ -268,8 +266,8 @@ removeExportDirectoryM serial abase dir =
go = adbShellBool serial [Param "rm", Param "-rf", File (fromAndroidPath adir)] go = adbShellBool serial [Param "rm", Param "-rf", File (fromAndroidPath adir)]
adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir)) adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir))
checkPresentExportM :: Remote -> AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool
checkPresentExportM r serial adir _k loc = checkKey' r serial aloc checkPresentExportM serial adir _k loc = checkKey' serial aloc
where where
aloc = androidExportLocation adir loc aloc = androidExportLocation adir loc

View file

@ -27,7 +27,6 @@ import Config.Cost
import qualified Remote.Helper.Ssh as Ssh import qualified Remote.Helper.Ssh as Ssh
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Utility.Hash import Utility.Hash
import Utility.UserInfo import Utility.UserInfo
@ -110,7 +109,7 @@ gen r u rc gc rs = do
(store this buprepo) (store this buprepo)
(retrieve buprepo) (retrieve buprepo)
(remove buprepo) (remove buprepo)
(checkKey r bupr') (checkKey bupr')
this this
where where
buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc
@ -212,11 +211,9 @@ remove buprepo k = do
- in a bup repository. One way it to check if the git repository has - in a bup repository. One way it to check if the git repository has
- a branch matching the name (as created by bup split -n). - a branch matching the name (as created by bup split -n).
-} -}
checkKey :: Git.Repo -> Git.Repo -> CheckPresent checkKey :: Git.Repo -> CheckPresent
checkKey r bupr k checkKey bupr k
| Git.repoIsUrl bupr = do | Git.repoIsUrl bupr = onBupRemote bupr boolSystem "git" params
showChecking r
onBupRemote bupr boolSystem "git" params
| otherwise = liftIO $ boolSystem "git" $ | otherwise = liftIO $ boolSystem "git" $
Git.Command.gitCommandLine params bupr Git.Command.gitCommandLine params bupr
where where

View file

@ -27,7 +27,6 @@ import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Remote.Helper.ReadOnly import Remote.Helper.ReadOnly
import Remote.Helper.Messages
import Utility.Metered import Utility.Metered
import Types.Transfer import Types.Transfer
import Logs.PreferredContent.Raw import Logs.PreferredContent.Raw
@ -71,7 +70,7 @@ gen r u rc gc rs
readonlyStorer readonlyStorer
retrieveUrl retrieveUrl
readonlyRemoveKey readonlyRemoveKey
(checkKeyUrl r) checkKeyUrl
Nothing Nothing
(externalInfo externaltype) (externalInfo externaltype)
Nothing Nothing
@ -815,9 +814,8 @@ retrieveUrl = fileRetriever $ \f k p -> do
unlessM (withUrlOptions $ downloadUrl k p us f) $ unlessM (withUrlOptions $ downloadUrl k p us f) $
giveup "failed to download content" giveup "failed to download content"
checkKeyUrl :: Git.Repo -> CheckPresent checkKeyUrl :: CheckPresent
checkKeyUrl r k = do checkKeyUrl k = do
showChecking r
us <- getWebUrls k us <- getWebUrls k
anyM (\u -> withUrlOptions $ checkBoth u (fromKey keySize k)) us anyM (\u -> withUrlOptions $ checkBoth u (fromKey keySize k)) us

View file

@ -460,7 +460,7 @@ checkKey' repo r rsyncopts accessmethod k
| accessmethod == AccessRsyncOverSsh = checkrsync | accessmethod == AccessRsyncOverSsh = checkrsync
| otherwise = unsupportedUrl | otherwise = unsupportedUrl
where where
checkrsync = Remote.Rsync.checkKey repo rsyncopts k checkrsync = Remote.Rsync.checkKey rsyncopts k
checkshell = Ssh.inAnnex repo k checkshell = Ssh.inAnnex repo k
{- Annexed objects are hashed using lower-case directories for max {- Annexed objects are hashed using lower-case directories for max

View file

@ -407,7 +407,6 @@ inAnnex' repo rmt st@(State connpool duc _ _ _) key
| otherwise = checklocal | otherwise = checklocal
where where
checkhttp = do checkhttp = do
showChecking repo
gc <- Annex.getGitConfig gc <- Annex.getGitConfig
ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key)) ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key))
( return True ( return True

View file

@ -19,7 +19,6 @@ import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import qualified Remote.Helper.AWS as AWS import qualified Remote.Helper.AWS as AWS
import Creds import Creds
@ -222,9 +221,7 @@ remove r k = unlessM go $
] ]
checkKey :: Remote -> CheckPresent checkKey :: Remote -> CheckPresent
checkKey r k = do checkKey r k = go =<< glacierEnv (config r) (gitconfig r) (uuid r)
showChecking r
go =<< glacierEnv (config r) (gitconfig r) (uuid r)
where where
go Nothing = giveup "cannot check glacier" go Nothing = giveup "cannot check glacier"
go (Just e) = do go (Just e) = do

View file

@ -25,9 +25,6 @@ instance Describable (Remote.RemoteA a) where
instance Describable String where instance Describable String where
describe = id describe = id
showChecking :: Describable a => a -> Annex ()
showChecking v = showAction $ "checking " ++ describe v
cantCheck :: Describable a => a -> e cantCheck :: Describable a => a -> e
cantCheck v = giveup $ "unable to check " ++ describe v cantCheck v = giveup $ "unable to check " ++ describe v

View file

@ -94,9 +94,8 @@ onRemote cs r (with, errorval) command params fields = do
{- Checks if a remote contains a key. -} {- Checks if a remote contains a key. -}
inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex :: Git.Repo -> Key -> Annex Bool
inAnnex r k = do inAnnex r k = onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex"
showChecking r [Param $ serializeKey k] []
onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] []
where where
runcheck c p = liftIO $ dispatch =<< safeSystem c p runcheck c p = liftIO $ dispatch =<< safeSystem c p
dispatch ExitSuccess = return True dispatch ExitSuccess = return True

View file

@ -17,7 +17,6 @@ import Config.Cost
import Annex.UUID import Annex.UUID
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Utility.Env import Utility.Env
import Messages.Progress import Messages.Progress
@ -54,7 +53,7 @@ gen r u rc gc rs = do
(store hooktype) (store hooktype)
(retrieve hooktype) (retrieve hooktype)
(remove hooktype) (remove hooktype)
(checkKey r hooktype) (checkKey hooktype)
Remote Remote
{ uuid = u { uuid = u
, cost = cst , cost = cst
@ -169,9 +168,8 @@ remove h k =
unlessM (runHook' h "remove" k Nothing $ return True) $ unlessM (runHook' h "remove" k Nothing $ return True) $
giveup "failed to remove content" giveup "failed to remove content"
checkKey :: Git.Repo -> HookName -> CheckPresent checkKey :: HookName -> CheckPresent
checkKey r h k = do checkKey h k = do
showChecking r
v <- lookupHook h action v <- lookupHook h action
liftIO $ check v liftIO $ check v
where where

View file

@ -11,7 +11,6 @@ import Annex.Common
import Types.Remote import Types.Remote
import Types.ProposedAccepted import Types.ProposedAccepted
import Types.Export import Types.Export
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Remote.Helper.Special import Remote.Helper.Special
import qualified Git import qualified Git
@ -67,7 +66,7 @@ gen r u rc gc rs = do
, retrievalSecurityPolicy = RetrievalAllKeysSecure , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = cannotModify , removeKey = cannotModify
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkKey url ll (this url ll c cst) , checkPresent = checkKey url ll
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = ExportActions , exportActions = ExportActions
{ storeExport = cannotModify { storeExport = cannotModify
@ -130,9 +129,8 @@ downloadAction dest p key run =
run (\url -> Url.download' p url dest uo) run (\url -> Url.download' p url dest uo)
>>= either giveup (const (return ())) >>= either giveup (const (return ()))
checkKey :: Maybe URLString -> LearnedLayout -> Remote -> Key -> Annex Bool checkKey :: Maybe URLString -> LearnedLayout -> Key -> Annex Bool
checkKey baseurl ll r key = do checkKey baseurl ll key =
showChecking r
isRight <$> keyUrlAction baseurl ll key (checkKey' key) isRight <$> keyUrlAction baseurl ll key (checkKey' key)
checkKey' :: Key -> URLString -> Annex (Either String ()) checkKey' :: Key -> URLString -> Annex (Either String ())

View file

@ -29,7 +29,6 @@ import Annex.UUID
import Annex.Ssh import Annex.Ssh
import Annex.Perms import Annex.Perms
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Types.Export import Types.Export
import Types.ProposedAccepted import Types.ProposedAccepted
@ -84,7 +83,7 @@ gen r u rc gc rs = do
(fileStorer $ store o) (fileStorer $ store o)
(fileRetriever $ retrieve o) (fileRetriever $ retrieve o)
(remove o) (remove o)
(checkKey r o) (checkKey o)
Remote Remote
{ uuid = u { uuid = u
, cost = cst , cost = cst
@ -280,10 +279,8 @@ removeGeneric o includes = do
unless ok $ unless ok $
giveup "rsync failed" giveup "rsync failed"
checkKey :: Git.Repo -> RsyncOpts -> CheckPresent checkKey :: RsyncOpts -> CheckPresent
checkKey r o k = do checkKey o k = checkPresentGeneric o (rsyncUrls o k)
showChecking r
checkPresentGeneric o (rsyncUrls o k)
checkPresentGeneric :: RsyncOpts -> [RsyncUrl] -> Annex Bool checkPresentGeneric :: RsyncOpts -> [RsyncUrl] -> Annex Bool
checkPresentGeneric o rsyncurls = do checkPresentGeneric o rsyncurls = do

View file

@ -47,7 +47,6 @@ import Config.Cost
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Http import Remote.Helper.Http
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Types.Import import Types.Import
import qualified Remote.Helper.AWS as AWS import qualified Remote.Helper.AWS as AWS
@ -449,9 +448,7 @@ lockContentS3 hv r rs c info
checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent
checkKey hv r rs c info k = withS3Handle hv $ \case checkKey hv r rs c info k = withS3Handle hv $ \case
Just h -> do Just h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
showChecking r
eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning failreason
giveup "cannot check content" giveup "cannot check content"
@ -462,7 +459,6 @@ checkKey hv r rs c info k = withS3Handle hv $ \case
warning failreason warning failreason
giveup "cannot check content" giveup "cannot check content"
Right us -> do Right us -> do
showChecking r
let check u = withUrlOptions $ let check u = withUrlOptions $
Url.checkBoth u (fromKey keySize k) Url.checkBoth u (fromKey keySize k)
anyM check us anyM check us

View file

@ -9,7 +9,6 @@ module Remote.Web (remote, getWebUrls) where
import Annex.Common import Annex.Common
import Types.Remote import Types.Remote
import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import qualified Git import qualified Git
import qualified Git.Construct import qualified Git.Construct
@ -112,7 +111,6 @@ checkKey key = do
checkKey' :: Key -> [URLString] -> Annex (Either String Bool) checkKey' :: Key -> [URLString] -> Annex (Either String Bool)
checkKey' key us = firsthit us (Right False) $ \u -> do checkKey' key us = firsthit us (Right False) $ \u -> do
let (u', downloader) = getDownloader u let (u', downloader) = getDownloader u
showChecking u'
case downloader of case downloader of
YoutubeDownloader -> youtubeDlCheck u' YoutubeDownloader -> youtubeDlCheck u'
_ -> catchMsgIO $ _ -> catchMsgIO $

View file

@ -33,7 +33,6 @@ import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.Http import Remote.Helper.Http
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import qualified Remote.Helper.Chunked.Legacy as Legacy import qualified Remote.Helper.Chunked.Legacy as Legacy
@ -78,7 +77,7 @@ gen r u rc gc rs = do
(store hdl chunkconfig) (store hdl chunkconfig)
(retrieve hdl chunkconfig) (retrieve hdl chunkconfig)
(remove hdl) (remove hdl)
(checkKey hdl this chunkconfig) (checkKey hdl chunkconfig)
this this
where where
this = Remote this = Remote
@ -198,9 +197,8 @@ removeHelper d = do
Right False -> return () Right False -> return ()
_ -> giveup "failed to remove content from remote" _ -> giveup "failed to remove content from remote"
checkKey :: DavHandleVar -> Remote -> ChunkConfig -> CheckPresent checkKey :: DavHandleVar -> ChunkConfig -> CheckPresent
checkKey hv r chunkconfig k = withDavHandle hv $ \dav -> do checkKey hv chunkconfig k = withDavHandle hv $ \dav ->
showChecking r
case chunkconfig of case chunkconfig of
LegacyChunks _ -> checkKeyLegacyChunked dav k LegacyChunks _ -> checkKeyLegacyChunked dav k
_ -> do _ -> do