git-annex/Remote/Helper/P2P.hs
Joey Hess 5b332a87be
dropping from clusters
Dropping from a cluster drops from every node of the cluster.
Including nodes that the cluster does not think have the content.
This is different from GET and CHECKPRESENT, which do trust the
cluster's location log. The difference is that removing from a cluster
should make 100% the content is gone from every node. So doing extra
work is ok. Compare with CHECKPRESENT where checking every node could
make it very expensive, and the worst that can happen in a false
negative is extra work being done.

Extended the P2P protocol with FAILURE-PLUS to handle the case where a
drop from one node succeeds, but a drop from another node fails. In that
case the entire cluster drop has failed.

Note that SUCCESS-PLUS is returned when dropping from a proxied remote
that is not a cluster, when the protocol version supports it. This is
because P2P.Proxy does not know when it's proxying for a single node
cluster vs for a remote that is not a cluster.
2024-06-23 09:43:40 -04:00

96 lines
3.4 KiB
Haskell

{- Helpers for remotes using the git-annex P2P protocol.
-
- Copyright 2016-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE RankNTypes #-}
module Remote.Helper.P2P where
import Annex.Common
import qualified P2P.Protocol as P2P
import P2P.IO
import Types.Remote
import Annex.Content
import Messages.Progress
import Utility.Metered
import Utility.Tuple
import Types.NumCopies
import Annex.Verify
import Logs.Location
import Control.Concurrent
-- Runs a Proto action using a connection it sets up.
type ProtoRunner a = P2P.Proto a -> Annex (Maybe a)
-- Runs a Proto action using a ClosableConnection.
type ProtoConnRunner c = forall a. P2P.Proto a -> ClosableConnection c -> Annex (ClosableConnection c, Maybe a)
-- Runs an Annex action with a connection from the pool, adding it back to
-- the pool when done.
type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a
store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> MeterUpdate -> Annex ()
store remoteuuid gc runner k af p = do
let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k)
let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc
metered (Just p) sizer bwlimit $ \_ p' ->
runner (P2P.put k af p') >>= \case
Just (Just fanoutuuids) -> do
-- Storing on the remote can cause it
-- to be stored on additional UUIDs,
-- so record those.
forM_ fanoutuuids $ \u ->
when (u /= remoteuuid) $
logChange k u InfoPresent
Just Nothing -> giveup "Transfer failed"
Nothing -> remoteUnavail
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve gc runner k af dest p verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc
metered (Just p) k bwlimit $ \m p' ->
runner (P2P.get dest k iv af m p') >>= \case
Just (True, v) -> return v
Just (False, _) -> giveup "Transfer failed"
Nothing -> remoteUnavail
remove :: UUID -> ProtoRunner (Bool, Maybe [UUID]) -> Key -> Annex ()
remove remoteuuid runner k = runner (P2P.remove k) >>= \case
Just (True, alsoremoveduuids) -> note alsoremoveduuids
Just (False, alsoremoveduuids) -> do
note alsoremoveduuids
giveup "removing content from remote failed"
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 Bool -> Key -> Annex Bool
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
connv <- liftIO $ newMVar conn
let runproto d p = do
c <- liftIO $ takeMVar connv
(c', mr) <- connrunner p c
liftIO $ putMVar connv c'
return (fromMaybe d mr)
r <- P2P.lockContentWhile runproto k go
conn' <- liftIO $ takeMVar connv
return (conn', r)
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"