Remote.Git removeKey works with annex+http urls
Does not yet handle drop proof lock timestamp checking.
This commit is contained in:
parent
fd3bdb2300
commit
9fa9678585
4 changed files with 38 additions and 36 deletions
|
@ -210,29 +210,26 @@ clientCheckPresent _ = ()
|
||||||
|
|
||||||
#ifdef WITH_SERVANT
|
#ifdef WITH_SERVANT
|
||||||
clientRemove
|
clientRemove
|
||||||
:: ClientEnv
|
:: Maybe SafeDropProof
|
||||||
-> ProtocolVersion
|
-> Key
|
||||||
-> B64Key
|
-> ClientAction RemoveResultPlus
|
||||||
-> B64UUID ServerSide
|
clientRemove proof k clientenv (ProtocolVersion ver) su cu bypass auth =
|
||||||
-> B64UUID ClientSide
|
liftIO $ withClientM cli clientenv return
|
||||||
-> [B64UUID Bypass]
|
|
||||||
-> Maybe Auth
|
|
||||||
-> IO RemoveResultPlus
|
|
||||||
clientRemove clientenv (ProtocolVersion ver) key su cu bypass auth =
|
|
||||||
withClientM cli clientenv $ \case
|
|
||||||
Left err -> throwM err
|
|
||||||
Right res -> return res
|
|
||||||
where
|
where
|
||||||
|
bk = B64Key k
|
||||||
|
|
||||||
cli = case ver of
|
cli = case ver of
|
||||||
3 -> v3 su V3 key cu bypass auth
|
3 -> v3 su V3 bk cu bypass auth
|
||||||
2 -> v2 su V2 key cu bypass auth
|
2 -> v2 su V2 bk cu bypass auth
|
||||||
1 -> plus <$> v1 su V1 key cu bypass auth
|
1 -> plus <$> v1 su V1 bk cu bypass auth
|
||||||
0 -> plus <$> v0 su V0 key cu bypass auth
|
0 -> plus <$> v0 su V0 bk cu bypass auth
|
||||||
_ -> error "unsupported protocol version"
|
_ -> error "unsupported protocol version"
|
||||||
|
|
||||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||||
_ :<|> _ :<|> _ :<|> _ :<|>
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
||||||
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
||||||
|
#else
|
||||||
|
clientRemove _ _ = ()
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#ifdef WITH_SERVANT
|
#ifdef WITH_SERVANT
|
||||||
|
|
|
@ -475,11 +475,17 @@ dropKey r st proof key = do
|
||||||
|
|
||||||
dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
|
dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
|
||||||
dropKey' repo r st@(State connpool duc _ _ _) proof key
|
dropKey' repo r st@(State connpool duc _ _ _) proof key
|
||||||
|
| isP2PHttp r = p2pHttpClient r giveup (clientRemove proof key) >>= \case
|
||||||
|
RemoveResultPlus True fanoutuuids ->
|
||||||
|
storefanout fanoutuuids
|
||||||
|
RemoveResultPlus False fanoutuuids -> do
|
||||||
|
storefanout fanoutuuids
|
||||||
|
giveup "removing content from remote failed"
|
||||||
| not $ Git.repoIsUrl repo = ifM duc
|
| not $ Git.repoIsUrl repo = ifM duc
|
||||||
( guardUsable repo (giveup "cannot access remote") removelocal
|
( guardUsable repo (giveup "cannot access remote") removelocal
|
||||||
, giveup "remote does not have expected annex.uuid value"
|
, giveup "remote does not have expected annex.uuid value"
|
||||||
)
|
)
|
||||||
| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
|
| Git.repoIsHttp repo = giveup "dropping from this remote is not supported"
|
||||||
| otherwise = P2PHelper.remove (uuid r) p2prunner proof key
|
| otherwise = P2PHelper.remove (uuid r) p2prunner proof key
|
||||||
where
|
where
|
||||||
p2prunner = Ssh.runProto r connpool (return (Right False, Nothing))
|
p2prunner = Ssh.runProto r connpool (return (Right False, Nothing))
|
||||||
|
@ -505,6 +511,8 @@ dropKey' repo r st@(State connpool duc _ _ _) proof key
|
||||||
)
|
)
|
||||||
unless proofunexpired
|
unless proofunexpired
|
||||||
safeDropProofExpired
|
safeDropProofExpired
|
||||||
|
|
||||||
|
storefanout = P2PHelper.storeFanout key InfoMissing (uuid r) . map fromB64UUID
|
||||||
|
|
||||||
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
||||||
lockKey r st key callback = do
|
lockKey r st key callback = do
|
||||||
|
@ -570,7 +578,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
|
||||||
(gitconfig r)
|
(gitconfig r)
|
||||||
(Ssh.runProto r connpool (return (False, UnVerified)))
|
(Ssh.runProto r connpool (return (False, UnVerified)))
|
||||||
key af dest meterupdate vc
|
key af dest meterupdate vc
|
||||||
| otherwise = giveup "copying from non-ssh, non-http remote not supported"
|
| otherwise = giveup "copying from this remote is not supported"
|
||||||
where
|
where
|
||||||
bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
|
bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
|
||||||
<|> remoteAnnexBwLimit (gitconfig r)
|
<|> remoteAnnexBwLimit (gitconfig r)
|
||||||
|
@ -674,14 +682,15 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
|
||||||
res <- p2pHttpClient r giveup $
|
res <- p2pHttpClient r giveup $
|
||||||
clientPut p' key (Just offset) af object sz check'
|
clientPut p' key (Just offset) af object sz check'
|
||||||
case res of
|
case res of
|
||||||
PutResultPlus False _ ->
|
PutResultPlus False fanoutuuids -> do
|
||||||
|
storefanout fanoutuuids
|
||||||
failedsend
|
failedsend
|
||||||
PutResultPlus True fanoutuuids ->
|
PutResultPlus True fanoutuuids ->
|
||||||
storefanout fanoutuuids
|
storefanout fanoutuuids
|
||||||
PutOffsetResultAlreadyHavePlus fanoutuuids ->
|
PutOffsetResultAlreadyHavePlus fanoutuuids ->
|
||||||
storefanout fanoutuuids
|
storefanout fanoutuuids
|
||||||
|
|
||||||
storefanout = P2PHelper.storeFanout key (uuid r) . map fromB64UUID
|
storefanout = P2PHelper.storeFanout key InfoPresent (uuid r) . map fromB64UUID
|
||||||
|
|
||||||
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
|
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
|
||||||
fsckOnRemote r params
|
fsckOnRemote r params
|
||||||
|
|
|
@ -43,17 +43,15 @@ store remoteuuid gc runner k af o p = do
|
||||||
metered (Just p) sizer bwlimit $ \_ p' ->
|
metered (Just p) sizer bwlimit $ \_ p' ->
|
||||||
runner (P2P.put k af p') >>= \case
|
runner (P2P.put k af p') >>= \case
|
||||||
Just (Just fanoutuuids) ->
|
Just (Just fanoutuuids) ->
|
||||||
storeFanout k remoteuuid fanoutuuids
|
storeFanout k InfoPresent remoteuuid fanoutuuids
|
||||||
Just Nothing -> giveup "Transfer failed"
|
Just Nothing -> giveup "Transfer failed"
|
||||||
Nothing -> remoteUnavail
|
Nothing -> remoteUnavail
|
||||||
|
|
||||||
storeFanout :: Key -> UUID -> [UUID] -> Annex ()
|
storeFanout :: Key -> LogStatus -> UUID -> [UUID] -> Annex ()
|
||||||
storeFanout k remoteuuid us =
|
storeFanout k logstatus remoteuuid us =
|
||||||
-- Storing on the remote can cause it to be stored on additional UUIDs,
|
|
||||||
-- so record those.
|
|
||||||
forM_ us $ \u ->
|
forM_ us $ \u ->
|
||||||
when (u /= remoteuuid) $
|
when (u /= remoteuuid) $
|
||||||
logChange k u InfoPresent
|
logChange k u logstatus
|
||||||
|
|
||||||
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
|
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
|
||||||
retrieve gc runner k af dest p verifyconfig = do
|
retrieve gc runner k af dest p verifyconfig = do
|
||||||
|
@ -67,20 +65,16 @@ retrieve gc runner k af dest p verifyconfig = do
|
||||||
|
|
||||||
remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Maybe SafeDropProof -> Key -> Annex ()
|
remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Maybe SafeDropProof -> Key -> Annex ()
|
||||||
remove remoteuuid runner proof k = runner (P2P.remove proof k) >>= \case
|
remove remoteuuid runner proof k = runner (P2P.remove proof k) >>= \case
|
||||||
Just (Right True, alsoremoveduuids) -> note alsoremoveduuids
|
Just (Right True, alsoremoveduuids) ->
|
||||||
|
storeFanout k InfoMissing remoteuuid
|
||||||
|
(fromMaybe [] alsoremoveduuids)
|
||||||
Just (Right False, alsoremoveduuids) -> do
|
Just (Right False, alsoremoveduuids) -> do
|
||||||
note alsoremoveduuids
|
storeFanout k InfoMissing remoteuuid
|
||||||
|
(fromMaybe [] alsoremoveduuids)
|
||||||
giveup "removing content from remote failed"
|
giveup "removing content from remote failed"
|
||||||
Just (Left err, _) -> do
|
Just (Left err, _) -> do
|
||||||
giveup (safeOutput err)
|
giveup (safeOutput err)
|
||||||
Nothing -> remoteUnavail
|
Nothing -> remoteUnavail
|
||||||
where
|
|
||||||
-- The remote reports removal from other UUIDs than its own,
|
|
||||||
-- so record those.
|
|
||||||
note alsoremoveduuids =
|
|
||||||
forM_ (fromMaybe [] alsoremoveduuids) $ \u ->
|
|
||||||
when (u /= remoteuuid) $
|
|
||||||
logChange k u InfoMissing
|
|
||||||
|
|
||||||
checkpresent :: ProtoRunner (Either String Bool) -> Key -> Annex Bool
|
checkpresent :: ProtoRunner (Either String Bool) -> Key -> Annex Bool
|
||||||
checkpresent runner k =
|
checkpresent runner k =
|
||||||
|
|
|
@ -28,7 +28,9 @@ Planned schedule of work:
|
||||||
|
|
||||||
## work notes
|
## work notes
|
||||||
|
|
||||||
* Rest of Remote.Git needs implementing: drop, lock
|
* Drop needs to check the proof and use timestamps.
|
||||||
|
|
||||||
|
* Rest of Remote.Git needs implementing: lock
|
||||||
|
|
||||||
* A Locker should expire the lock on its own after 10 minutes,
|
* A Locker should expire the lock on its own after 10 minutes,
|
||||||
initially. Once keeplocked is called, the lock will expire at the end
|
initially. Once keeplocked is called, the lock will expire at the end
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue