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,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
]