make removeKey throw exceptions
This commit is contained in:
parent
b5ee97f32a
commit
4be94c67c7
28 changed files with 134 additions and 111 deletions
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
]
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue