From 9fa9678585e955662146c542d9ccc03fe16cab31 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 24 Jul 2024 12:33:26 -0400 Subject: [PATCH] Remote.Git removeKey works with annex+http urls Does not yet handle drop proof lock timestamp checking. --- P2P/Http/Client.hs | 29 +++++++++++++---------------- Remote/Git.hs | 17 +++++++++++++---- Remote/Helper/P2P.hs | 24 +++++++++--------------- doc/todo/git-annex_proxies.mdwn | 4 +++- 4 files changed, 38 insertions(+), 36 deletions(-) diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs index ed0773ddd9..5d6d3f420a 100644 --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -210,29 +210,26 @@ clientCheckPresent _ = () #ifdef WITH_SERVANT clientRemove - :: ClientEnv - -> ProtocolVersion - -> B64Key - -> B64UUID ServerSide - -> B64UUID ClientSide - -> [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 + :: Maybe SafeDropProof + -> Key + -> ClientAction RemoveResultPlus +clientRemove proof k clientenv (ProtocolVersion ver) su cu bypass auth = + liftIO $ withClientM cli clientenv return where + bk = B64Key k + cli = case ver of - 3 -> v3 su V3 key cu bypass auth - 2 -> v2 su V2 key cu bypass auth - 1 -> plus <$> v1 su V1 key cu bypass auth - 0 -> plus <$> v0 su V0 key cu bypass auth + 3 -> v3 su V3 bk cu bypass auth + 2 -> v2 su V2 bk cu bypass auth + 1 -> plus <$> v1 su V1 bk cu bypass auth + 0 -> plus <$> v0 su V0 bk cu bypass auth _ -> error "unsupported protocol version" _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI +#else +clientRemove _ _ = () #endif #ifdef WITH_SERVANT diff --git a/Remote/Git.hs b/Remote/Git.hs index a52884fee4..8edb5f5449 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -475,11 +475,17 @@ dropKey r st proof key = do dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex () 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 ( guardUsable repo (giveup "cannot access remote") removelocal , 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 where p2prunner = Ssh.runProto r connpool (return (Right False, Nothing)) @@ -505,6 +511,8 @@ dropKey' repo r st@(State connpool duc _ _ _) proof key ) unless proofunexpired safeDropProofExpired + + storefanout = P2PHelper.storeFanout key InfoMissing (uuid r) . map fromB64UUID lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r st key callback = do @@ -570,7 +578,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc (gitconfig r) (Ssh.runProto r connpool (return (False, UnVerified))) 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 bwlimit = remoteAnnexBwLimitDownload (gitconfig r) <|> remoteAnnexBwLimit (gitconfig r) @@ -674,14 +682,15 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate res <- p2pHttpClient r giveup $ clientPut p' key (Just offset) af object sz check' case res of - PutResultPlus False _ -> + PutResultPlus False fanoutuuids -> do + storefanout fanoutuuids failedsend PutResultPlus True fanoutuuids -> storefanout fanoutuuids PutOffsetResultAlreadyHavePlus 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 r params diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 9f61497041..a0b18646a0 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -43,17 +43,15 @@ store remoteuuid gc runner k af o p = do metered (Just p) sizer bwlimit $ \_ p' -> runner (P2P.put k af p') >>= \case Just (Just fanoutuuids) -> - storeFanout k remoteuuid fanoutuuids + storeFanout k InfoPresent remoteuuid fanoutuuids Just Nothing -> giveup "Transfer failed" Nothing -> remoteUnavail -storeFanout :: Key -> UUID -> [UUID] -> Annex () -storeFanout k remoteuuid us = - -- Storing on the remote can cause it to be stored on additional UUIDs, - -- so record those. +storeFanout :: Key -> LogStatus -> UUID -> [UUID] -> Annex () +storeFanout k logstatus remoteuuid us = forM_ us $ \u -> when (u /= remoteuuid) $ - logChange k u InfoPresent + logChange k u logstatus retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification 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 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 - note alsoremoveduuids + storeFanout k InfoMissing remoteuuid + (fromMaybe [] alsoremoveduuids) giveup "removing content from remote failed" Just (Left err, _) -> do giveup (safeOutput err) 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 runner k = diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn index d5cb62fc01..529092b4db 100644 --- a/doc/todo/git-annex_proxies.mdwn +++ b/doc/todo/git-annex_proxies.mdwn @@ -28,7 +28,9 @@ Planned schedule of work: ## 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, initially. Once keeplocked is called, the lock will expire at the end