summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-11-18 01:32:24 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-11-18 01:32:24 -0400
commita00349b3096ddb9f51e2acbc73b87a73384afe55 (patch)
treea5dbb577a90bb0dfcc87de0d3e9f975e0da455d0 /Remote
parent681b8e1f9c6597e3ad15b61db12b1403d3c9667f (diff)
Add content locking to P2P protocol
Is content locking needed in the P2P protocol? Based on re-reading bugs/concurrent_drop--from_presence_checking_failures.mdwn, I think so: Peers can form cycles, and multiple peers can all be trying to drop the same content. So, added content locking to the protocol, with some difficulty. The implementation is fine as far as it goes, but note the warning comment for lockContentWhile -- if the connection to the peer is dropped unexpectedly, the peer will then unlock the content, and yet the local side will still think it's locked. To be honest I'm not sure if Remote.Git's lockKey for ssh remotes doesn't have the same problem. It checks that the "ssh remote git-annex-shell lockcontent" process has not exited, but if the connection closes afer that check, the lockcontent command will unlock it, and yet the local side will still think it's locked. Probably this needs to be fixed by eg, making lockcontent catch any execptions due to the connection closing, and in that case, wait a significantly long time before dropping the lock. This commit was sponsored by Anthony DeRobertis on Patreon.
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Helper/P2P.hs41
1 files changed, 40 insertions, 1 deletions
diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs
index 38859914a..a62f7c03d 100644
--- a/Remote/Helper/P2P.hs
+++ b/Remote/Helper/P2P.hs
@@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts, RankNTypes #-}
module Remote.Helper.P2P (
AuthToken(..),
@@ -14,6 +14,7 @@ module Remote.Helper.P2P (
protoDump,
auth,
checkPresent,
+ lockContentWhile,
remove,
get,
put,
@@ -29,6 +30,7 @@ import Utility.PartialPrelude
import Control.Monad
import Control.Monad.Free
import Control.Monad.Free.TH
+import Control.Monad.Catch
import qualified Data.ByteString.Lazy as L
newtype AuthToken = AuthToken String
@@ -47,6 +49,8 @@ data Message
| AUTH_SUCCESS UUID -- uuid of the remote peer
| AUTH_FAILURE
| CHECKPRESENT Key
+ | LOCKCONTENT Key
+ | UNLOCKCONTENT
| REMOVE Key
| GET Offset Key
| PUT Key
@@ -84,6 +88,9 @@ data ProtoF next
| RemoveKeyFile Key (Bool -> next)
-- ^ If the key file is not present, still succeeds.
-- May fail if not enough copies to safely drop, etc.
+ | TryLockContent Key (Bool -> Proto ()) next
+ -- ^ Try to lock the content of a key, preventing it
+ -- from being deleted, and run the provided protocol action.
deriving (Functor)
type Proto = Free ProtoF
@@ -105,6 +112,7 @@ runPure (Free (CheckAuthToken _ _ next)) ms = runPure (next True) ms
runPure (Free (SetPresent _ _ next)) ms = runPure next ms
runPure (Free (CheckContentPresent _ next)) ms = runPure (next False) ms
runPure (Free (RemoveKeyFile _ next)) ms = runPure (next True) ms
+runPure (Free (TryLockContent _ p next)) ms = runPure (p True >> next) ms
protoDump :: [(String, Maybe Message)] -> String
protoDump = unlines . map protoDump'
@@ -129,6 +137,26 @@ checkPresent key = do
sendMessage (CHECKPRESENT key)
checkSuccess
+{- Locks content to prevent it from being dropped, while running an action.
+ -
+ - Note that this only guarantees that the content is locked as long as the
+ - connection to the peer remains up. If the connection is unexpectededly
+ - dropped, the peer will then unlock the content.
+ -}
+lockContentWhile
+ :: MonadMask m
+ => (forall r. Proto r -> m r)
+ -> Key
+ -> (Bool -> m ())
+ -> m ()
+lockContentWhile runproto key a = bracket setup cleanup a
+ where
+ setup = runproto $ do
+ sendMessage (LOCKCONTENT key)
+ checkSuccess
+ cleanup True = runproto $ sendMessage UNLOCKCONTENT
+ cleanup False = return ()
+
remove :: Key -> Proto Bool
remove key = do
sendMessage (REMOVE key)
@@ -183,6 +211,13 @@ serve myuuid = go Nothing
go autheduuid
authed _theiruuid r = case r of
+ LOCKCONTENT key -> tryLockContent key $ \locked -> do
+ sendSuccess locked
+ when locked $ do
+ r' <- receiveMessage
+ case r' of
+ UNLOCKCONTENT -> return ()
+ _ -> sendMessage (ERROR "expected UNLOCKCONTENT")
CHECKPRESENT key -> sendSuccess =<< checkContentPresent key
REMOVE key -> sendSuccess =<< removeKeyFile key
PUT key -> do
@@ -252,6 +287,8 @@ instance Proto.Sendable Message where
formatMessage (AUTH_SUCCESS uuid) = ["AUTH-SUCCESS", Proto.serialize uuid]
formatMessage AUTH_FAILURE = ["AUTH-FAILURE"]
formatMessage (CHECKPRESENT key) = ["CHECKPRESENT", Proto.serialize key]
+ formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key]
+ formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"]
formatMessage (REMOVE key) = ["REMOVE", Proto.serialize key]
formatMessage (GET offset key) = ["GET", Proto.serialize offset, Proto.serialize key]
formatMessage (PUT key) = ["PUT", Proto.serialize key]
@@ -267,6 +304,8 @@ instance Proto.Receivable Message where
parseCommand "AUTH-SUCCESS" = Proto.parse1 AUTH_SUCCESS
parseCommand "AUTH-FAILURE" = Proto.parse0 AUTH_FAILURE
parseCommand "CHECKPRESENT" = Proto.parse1 CHECKPRESENT
+ parseCommand "LOCKCONTENT" = Proto.parse1 LOCKCONTENT
+ parseCommand "UNLOCKCONTENT" = Proto.parse0 UNLOCKCONTENT
parseCommand "REMOVE" = Proto.parse1 REMOVE
parseCommand "GET" = Proto.parse2 GET
parseCommand "PUT" = Proto.parse1 PUT