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.
This commit is contained in:
parent
236ff111a7
commit
73a6b9b514
1 changed files with 40 additions and 1 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue