make removeKey throw exceptions

This commit is contained in:
Joey Hess 2020-05-14 14:08:09 -04:00
parent b5ee97f32a
commit 4be94c67c7
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
28 changed files with 134 additions and 111 deletions

View file

@ -199,7 +199,9 @@ retrieve' serial src dest = checkAdbInPath False $ do
]
remove :: AndroidSerial -> AndroidPath -> Remover
remove serial adir k = remove' serial (androidLocation adir k)
remove serial adir k =
unlessM (remove' serial (androidLocation adir k)) $
giveup "adb failed"
remove' :: AndroidSerial -> AndroidPath -> Annex Bool
remove' serial aloc = adbShellBool serial

View file

@ -112,10 +112,8 @@ downloadKey key _file dest p = do
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
uploadKey _ _ _ = giveup "upload to bittorrent not supported"
dropKey :: Key -> Annex Bool
dropKey k = do
mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
return True
dropKey :: Key -> Annex ()
dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
{- We punt and don't try to check if a torrent has enough seeders
- with all the pieces etc. That would be quite hard.. and even if

View file

@ -177,8 +177,7 @@ retrieve buprepo = byteRetriever $ \k sink -> do
remove :: BupRepo -> Remover
remove buprepo k = do
go =<< liftIO (bup2GitRemote buprepo)
warning "content cannot be completely removed from bup remote"
return True
giveup "content cannot be completely removed from bup remote"
where
go r
| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params

View file

@ -166,7 +166,8 @@ remove :: DdarRepo -> Remover
remove ddarrepo key = do
(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd'
[Param $ serializeKey key]
liftIO $ boolSystem cmd params
unlessM (liftIO $ boolSystem cmd params) $
giveup "ddar failed to remove"
ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool)
ddarDirectoryExists ddarrepo

View file

@ -226,14 +226,14 @@ removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k)
{- Removes the directory, which must be located under the topdir.
-
- Succeeds even on directories and contents that do not have write
- permission.
- permission, if it's possible to turn the write bit on.
-
- If the directory does not exist, succeeds as long as the topdir does
- exist. If the topdir does not exist, fails, because in this case the
- remote is not currently accessible and probably still has the content
- we were supposed to remove from it.
-}
removeDirGeneric :: FilePath -> FilePath -> IO Bool
removeDirGeneric :: FilePath -> FilePath -> IO ()
removeDirGeneric topdir dir = do
void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS
@ -241,12 +241,11 @@ removeDirGeneric topdir dir = do
- before it can delete them. -}
void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif
ok <- catchBoolIO $ do
removeDirectoryRecursive dir
return True
if ok
then return ok
else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
tryNonAsync (removeDirectoryRecursive dir) >>= \case
Right () -> return ()
Left e ->
unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
throwM e
checkPresentM :: FilePath -> ChunkConfig -> CheckPresent
checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k

View file

@ -222,7 +222,8 @@ checkExportSupported' external = go `catchNonAsync` (const (return False))
_ -> Nothing
storeKeyM :: External -> Storer
storeKeyM external = fileStorer $ \k f p -> either giveup return =<< go k f p
storeKeyM external = fileStorer $ \k f p ->
either giveup return =<< go k f p
where
go k f p = handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
case resp of
@ -233,26 +234,28 @@ storeKeyM external = fileStorer $ \k f p -> either giveup return =<< go k f p
_ -> Nothing
retrieveKeyFileM :: External -> Retriever
retrieveKeyFileM external = fileRetriever $ \d k p ->
handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
retrieveKeyFileM external = fileRetriever $ \d k p ->
either giveup return =<< go d k p
where
go d k p = handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
case resp of
TRANSFER_SUCCESS Download k'
| k == k' -> result ()
| k == k' -> result $ Right ()
TRANSFER_FAILURE Download k' errmsg
| k == k' -> Just $ giveup $
| k == k' -> result $ Left $
respErrorMessage "TRANSFER" errmsg
_ -> Nothing
removeKeyM :: External -> Remover
removeKeyM external k = safely $
handleRequestKey external REMOVE k Nothing $ \resp ->
removeKeyM external k = either giveup return =<< go
where
go = handleRequestKey external REMOVE k Nothing $ \resp ->
case resp of
REMOVE_SUCCESS k'
| k == k' -> result True
| k == k' -> result $ Right ()
REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do
warning $ respErrorMessage "REMOVE" errmsg
return (Result False)
| k == k' -> result $ Left $
respErrorMessage "REMOVE" errmsg
_ -> Nothing
checkPresentM :: External -> CheckPresent

View file

@ -413,7 +413,7 @@ remove r rsyncopts k = do
remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Remover
remove' repo r rsyncopts k
| not $ Git.repoIsUrl repo = guardUsable repo (return False) $
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation repo) (parentDir (gCryptLocation repo k))
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| otherwise = unsupportedUrl

View file

@ -423,31 +423,26 @@ keyUrls gc repo r key = map tourl locs'
#endif
remoteconfig = gitconfig r
dropKey :: Remote -> State -> Key -> Annex Bool
dropKey :: Remote -> State -> Key -> Annex ()
dropKey r st key = do
repo <- getRepo r
catchNonAsync
(dropKey' repo r st key)
(\e -> warning (show e) >> return False)
dropKey' repo r st key
dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex ()
dropKey' repo r st@(State connpool duc _ _ _) key
| not $ Git.repoIsUrl repo = ifM duc
( guardUsable repo (return False) $
( guardUsable repo (giveup "cannot access remote") $
commitOnCleanup repo r st $ onLocalFast st $ do
whenM (Annex.Content.inAnnex key) $ do
Annex.Content.lockContentForRemoval key $ \lock -> do
Annex.Content.removeAnnex lock
logStatus key InfoMissing
Annex.Content.saveState True
return True
, return False
, giveup "remote does not have expected annex.uuid value"
)
| Git.repoIsHttp repo = do
warning "dropping from http remote not supported"
return False
| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
| otherwise = commitOnCleanup repo r st $ do
let fallback = Ssh.dropKey repo key
let fallback = Ssh.dropKey' repo key
P2PHelper.remove (Ssh.runProto r connpool (return False) fallback) key
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r

View file

@ -526,6 +526,4 @@ checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case
| otherwise -> return True
remove :: TVar LFSHandle -> Remover
remove _h _key = do
warning "git-lfs does not support removing content"
return False
remove _h _key = giveup "git-lfs does not support removing content"

View file

@ -201,13 +201,15 @@ retrieve' r k sink = go =<< glacierEnv c gc u
sink =<< liftIO (L.hGetContents h)
remove :: Remote -> Remover
remove r k = glacierAction r
[ Param "archive"
, Param "delete"
, Param $ getVault $ config r
, Param $ archive r k
]
remove r k = unlessM go $
giveup "removal from glacier failed"
where
go = glacierAction r
[ Param "archive"
, Param "delete"
, Param $ getVault $ config r
, Param $ archive r k
]
checkKey :: Remote -> CheckPresent
checkKey r k = do

View file

@ -199,19 +199,14 @@ seekResume h encryptor chunkkeys checker = do
{- Removes all chunks of a key from a remote, by calling a remover
- action on each.
-
- The remover action should succeed even if asked to
- remove a key that is not present on the remote.
-
- This action may be called on a chunked key. It will simply remove it.
-}
removeChunks :: (Key -> Annex Bool) -> UUID -> ChunkConfig -> EncKey -> Key -> Annex Bool
removeChunks :: Remover -> UUID -> ChunkConfig -> EncKey -> Key -> Annex ()
removeChunks remover u chunkconfig encryptor k = do
ls <- chunkKeys u chunkconfig k
ok <- allM (remover . encryptor) (concat ls)
when ok $ do
let chunksizes = catMaybes $ map (fromKey keyChunkSize <=< headMaybe) ls
forM_ chunksizes $ chunksRemoved u k . FixedSizeChunks . fromIntegral
return ok
mapM_ (remover . encryptor) (concat ls)
let chunksizes = catMaybes $ map (fromKey keyChunkSize <=< headMaybe) ls
forM_ chunksizes $ chunksRemoved u k . FixedSizeChunks . fromIntegral
{- Retrieves a key from a remote, using a retriever action.
-

View file

@ -214,9 +214,7 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o
-- files would not be dealt with correctly.
-- There does not seem to be a good use case for
-- removing a key from an export in any case.
, removeKey = \_k -> do
warning "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"
return False
, removeKey = \_k -> giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"
-- Can't lock content on exports, since they're
-- not key/value stores, and someone else could
-- change what's exported to a file at any time.

View file

@ -1,6 +1,6 @@
{- Helpers for remotes using the git-annex P2P protocol.
-
- Copyright 2016-2018 Joey Hess <id@joeyh.name>
- Copyright 2016-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -37,7 +37,7 @@ store runner k af p = do
runner p' (P2P.put k af p') >>= \case
Just True -> return ()
Just False -> giveup "transfer failed"
Nothing -> giveup "can't connect to remote"
Nothing -> remoteUnavail
retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
retrieve runner k af dest p =
@ -45,15 +45,16 @@ retrieve runner k af dest p =
runner p' (P2P.get dest k af m p') >>= \case
Just (True, v) -> return v
Just (False, _) -> giveup "transfer failed"
Nothing -> giveup "can't connec to remote"
Nothing -> remoteUnavail
remove :: ProtoRunner Bool -> Key -> Annex Bool
remove runner k = fromMaybe False <$> runner (P2P.remove k)
remove :: ProtoRunner Bool -> Key -> Annex ()
remove runner k = runner (P2P.remove k) >>= \case
Just True -> return ()
Just False -> giveup "removing content from remote failed"
Nothing -> remoteUnavail
checkpresent :: ProtoRunner Bool -> Key -> Annex Bool
checkpresent runner k = maybe unavail return =<< runner (P2P.checkPresent k)
where
unavail = giveup "can't connect to remote"
checkpresent runner k = maybe remoteUnavail return =<< runner (P2P.checkPresent k)
lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a
lock withconn connrunner u k callback = withconn $ \conn -> do
@ -69,3 +70,6 @@ lock withconn connrunner u k callback = withconn $ \conn -> do
where
go False = giveup "can't lock content"
go True = withVerifiedCopy LockedCopy u (return True) callback
remoteUnavail :: a
remoteUnavail = giveup "can't connect to remote"

View file

@ -47,8 +47,8 @@ adjustReadOnly r
readonlyStoreKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
readonlyStoreKey _ _ _ = readonlyFail
readonlyRemoveKey :: Key -> Annex Bool
readonlyRemoveKey _ = readonlyFail'
readonlyRemoveKey :: Key -> Annex ()
readonlyRemoveKey _ = readonlyFail
readonlyStorer :: Storer
readonlyStorer _ _ _ = readonlyFail

View file

@ -124,8 +124,8 @@ storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
storeKeyDummy _ _ _ = error "missing storeKey implementation"
retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification
retrieveKeyFileDummy _ _ _ _ = error "missing retrieveKeyFile implementation"
removeKeyDummy :: Key -> Annex Bool
removeKeyDummy _ = return False
removeKeyDummy :: Key -> Annex ()
removeKeyDummy _ = error "missing removeKey implementation"
checkPresentDummy :: Key -> Annex Bool
checkPresentDummy _ = error "missing checkPresent implementation"
@ -207,8 +207,6 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
cip = cipherKey c (gitconfig baser)
isencrypted = isEncrypted c
safely a = catchNonAsync a (\e -> warning (show e) >> return False)
-- chunk, then encrypt, then feed to the storer
storeKeyGen k p enc = sendAnnex k rollback $ \src ->
displayprogress p k (Just src) $ \p' ->
@ -236,7 +234,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
where
enck = maybe id snd enc
removeKeyGen k enc = safely $
removeKeyGen k enc =
removeChunks remover (uuid baser) chunkconfig enck k
where
enck = maybe id snd enc

View file

@ -106,8 +106,12 @@ inAnnex r k = do
dispatch _ = cantCheck r
{- Removes a key from a remote. -}
dropKey :: Git.Repo -> Key -> Annex Bool
dropKey r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
dropKey :: Git.Repo -> Key -> Annex ()
dropKey r key = unlessM (dropKey' r key) $
giveup "unable to remove key from remote"
dropKey' :: Git.Repo -> Key -> Annex Bool
dropKey' r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
[ Param "--quiet", Param "--force"
, Param $ serializeKey key
]

View file

@ -163,7 +163,9 @@ retrieve h = fileRetriever $ \d k _p ->
giveup "failed to retrieve content"
remove :: HookName -> Remover
remove h k = runHook' h "remove" k Nothing $ return True
remove h k =
unlessM (runHook' h "remove" k Nothing $ return True) $
giveup "failed to remove content"
checkKey :: Git.Repo -> HookName -> CheckPresent
checkKey r h k = do

View file

@ -260,8 +260,25 @@ remove o k = removeGeneric o includes
- except for the specified includes. Due to the way rsync traverses
- directories, the includes must match both the file to be deleted, and
- its parent directories, but not their other contents. -}
removeGeneric :: RsyncOpts -> [String] -> Annex Bool
removeGeneric :: RsyncOpts -> [String] -> Annex ()
removeGeneric o includes = do
ps <- sendParams
opts <- rsyncOptions o
ok <- withRsyncScratchDir $ \tmp -> liftIO $ do
{- Send an empty directory to rysnc to make it delete. -}
rsync $ opts ++ ps ++
map (\s -> Param $ "--include=" ++ s) includes ++
[ Param "--exclude=*" -- exclude everything else
, Param "--quiet", Param "--delete", Param "--recursive"
] ++ partialParams ++
[ Param $ addTrailingPathSeparator tmp
, Param $ rsyncUrl o
]
unless ok $
giveup "rsync failed"
removeGeneric' :: RsyncOpts -> [String] -> Annex Bool
removeGeneric' o includes = do
ps <- sendParams
opts <- rsyncOptions o
withRsyncScratchDir $ \tmp -> liftIO $ do
@ -310,14 +327,14 @@ checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
removeExportM o _k loc =
removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc
removeGeneric' o $ includes $ fromRawFilePath $ fromExportLocation loc
where
includes f = f : case upFrom f of
Nothing -> []
Just f' -> includes f'
removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool
removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
removeExportDirectoryM o ed = removeGeneric' o (allbelow d : includes d)
where
d = fromRawFilePath $ fromExportDirectory ed
allbelow f = f </> "***"

View file

@ -419,10 +419,10 @@ retrieveHelper' h f p req = liftIO $ runResourceT $ do
Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp
remove :: S3HandleVar -> Remote -> S3Info -> Remover
remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResourceT $ do
res <- tryNonAsync $ sendS3Handle h $
remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> do
S3.DeleteObjectResponse <- liftIO $ runResourceT $ sendS3Handle h $
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return $ either (const False) (const True) res
return ()
checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent
checkKey hv r rs c info k = withS3Handle hv $ \case

View file

@ -150,10 +150,8 @@ retrieve rs hdl k _f d _p = do
go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $
giveup "tahoe failed to reteieve content"
remove :: Key -> Annex Bool
remove _k = do
warning "content cannot be removed from tahoe remote"
return False
remove :: Key -> Annex ()
remove _k = giveup "content cannot be removed from tahoe remote"
checkKey :: RemoteStateHandle -> TahoeHandle -> Key -> Annex Bool
checkKey rs hdl k = go =<< getCapability rs k

View file

@ -100,10 +100,8 @@ downloadKey key _af dest p = do
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()
uploadKey _ _ _ = giveup "upload to web not supported"
dropKey :: Key -> Annex Bool
dropKey k = do
mapM_ (setUrlMissing k) =<< getWebUrls k
return True
dropKey :: Key -> Annex ()
dropKey k = mapM_ (setUrlMissing k) =<< getWebUrls k
checkKey :: Key -> Annex Bool
checkKey key = do

View file

@ -177,11 +177,12 @@ retrieveHelper loc d p = do
remove :: DavHandleVar -> Remover
remove hv k = withDavHandle' hv $ \case
Left _e -> return False
Right dav -> liftIO $ goDAV dav $
-- Delete the key's whole directory, including any
-- legacy chunked files, etc, in a single action.
removeHelper (keyDir k)
unlessM (removeHelper (keyDir k)) $
giveup "failed to remove content from remote"
Left e -> giveup e
removeHelper :: DavLocation -> DAVT IO Bool
removeHelper d = do