diff options
| author |  Joey Hess <joeyh@joeyh.name> | 2016-11-17 21:37:49 -0400 |
|---|---|---|
| committer | Joey Hess <joeyh@joeyh.name> | 2016-11-17 21:37:49 -0400 |
| commit | dd33867c7d4c944e8b7a64ccae6be7c87ca8f12a (patch) | |
| tree | 0b3f2a9d93c93f8e7ebc0a65d6837f29f06ac029 /Remote | |
| parent | 0a4a2af3ee769e93287e1f52f7aa5856c30f9dd4 (diff) | |
add ALREADY-HAVE response to PUT
Diffstat (limited to 'Remote')
| -rw-r--r-- | Remote/Helper/P2P.hs | 17 |
1 files changed, 14 insertions, 3 deletions
diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index b94eda850..985f524f0 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -47,6 +47,7 @@ data Message | GET Offset Key | PUT Key | PUT_FROM Offset + | ALREADY_HAVE | SUCCESS | FAILURE | DATA Len -- followed by bytes @@ -74,6 +75,8 @@ data ProtoF next -- content been transferred. | CheckAuthToken UUID AuthToken (Bool -> next) | SetPresent Key UUID next + | CheckPresent Key (Bool -> next) + -- ^ Checks if the whole content of the key is locally present. deriving (Functor) type Proto = Free ProtoF @@ -93,6 +96,7 @@ runPure (Free (ReadKeyFile _ _ next)) ms = runPure (next L.empty) ms runPure (Free (WriteKeyFile _ _ _ _ next)) ms = runPure (next True) ms runPure (Free (CheckAuthToken _ _ next)) ms = runPure (next True) ms runPure (Free (SetPresent _ _ next)) ms = runPure next ms +runPure (Free (CheckPresent _ next)) ms = runPure (next False) ms protoDump :: [(String, Maybe Message)] -> String protoDump = unlines . map protoDump' @@ -121,6 +125,7 @@ put key = do r <- getMessage case r of PUT_FROM offset -> sendContent key offset + ALREADY_HAVE -> return True _ -> do sendMessage (PROTO_ERROR "expected PUT_FROM") return False @@ -161,9 +166,13 @@ serve myuuid = go Nothing authed _theiruuid r = case r of PUT key -> do - ok <- receiveContent key PUT_FROM - when ok $ - setPresent key myuuid + have <- checkPresent key + if have + then sendMessage ALREADY_HAVE + else do + ok <- receiveContent key PUT_FROM + when ok $ + setPresent key myuuid -- setPresent not called because the peer may have -- requested the data but not permanatly stored it. GET offset key -> void $ sendContent key offset @@ -217,6 +226,7 @@ instance Proto.Sendable Message where formatMessage (GET offset key) = ["GET", Proto.serialize offset, Proto.serialize key] formatMessage (PUT key) = ["PUT", Proto.serialize key] formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] + formatMessage ALREADY_HAVE = ["ALREADY-HAVE"] formatMessage SUCCESS = ["SUCCESS"] formatMessage FAILURE = ["FAILURE"] formatMessage (DATA leng) = ["DATA", Proto.serialize leng] @@ -229,6 +239,7 @@ instance Proto.Receivable Message where parseCommand "GET" = Proto.parse2 GET parseCommand "PUT" = Proto.parse1 PUT parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM + parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE parseCommand "SUCCESS" = Proto.parse0 SUCCESS parseCommand "FAILURE" = Proto.parse0 FAILURE parseCommand "DATA" = Proto.parse1 DATA |