diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-11-18 01:32:24 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-11-18 01:32:24 -0400 |
commit | a00349b3096ddb9f51e2acbc73b87a73384afe55 (patch) | |
tree | a5dbb577a90bb0dfcc87de0d3e9f975e0da455d0 /Remote | |
parent | 681b8e1f9c6597e3ad15b61db12b1403d3c9667f (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.hs | 41 |
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 |