add CHECKPRESENT

Using SUCCESS to mean the content is present and FAILURE to mean it's not.

1 files changed, 16 insertions, 4 deletions

diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs
index 19647e5d9..666dc84be 100644
--- a/Remote/Helper/P2P.hs
+++ b/Remote/Helper/P2P.hs
@@ -13,6 +13,7 @@ module Remote.Helper.P2P (
 	runPure,
 	protoDump,
 	auth,
+	checkPresent,
 	remove,
 	get,
 	put,
@@ -45,6 +46,7 @@ data Message
 	= AUTH UUID AuthToken -- uuid of the peer that is authenticating
 	| AUTH_SUCCESS UUID -- uuid of the remote peer
 	| AUTH_FAILURE
+	| CHECKPRESENT Key
 	| REMOVE Key
 	| GET Offset Key
 	| PUT Key
@@ -77,7 +79,7 @@ data ProtoF next
 	-- content been transferred.
 	| CheckAuthToken UUID AuthToken (Bool -> next)
 	| SetPresent Key UUID next
-	| CheckPresent Key (Bool -> next)
+	| CheckContentPresent Key (Bool -> next)
 	-- ^ Checks if the whole content of the key is locally present.
 	| RemoveKeyFile Key (Bool -> next)
 	-- ^ If the key file is not present, still succeeds.
@@ -101,8 +103,8 @@ 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
-runPure (Free (RemoveKeyFile _ next)) ms = runPure (next False) ms
+runPure (Free (CheckContentPresent _ next)) ms = runPure (next False) ms
+runPure (Free (RemoveKeyFile _ next)) ms = runPure (next True) ms
 
 protoDump :: [(String, Maybe Message)] -> String
 protoDump = unlines . map protoDump'
@@ -122,6 +124,11 @@ auth myuuid t = do
 			sendMessage (PROTO_ERROR "auth failed")
 			return Nothing
 
+checkPresent :: Key -> Proto Bool
+checkPresent key = do
+	sendMessage (CHECKPRESENT key)
+	checkSuccess
+
 remove :: Key -> Proto Bool
 remove key = do
 	sendMessage (REMOVE key)
@@ -176,11 +183,14 @@ serve myuuid = go Nothing
 				go autheduuid
 	
 	authed _theiruuid r = case r of
+		CHECKPRESENT key -> do
+			ok <- checkContentPresent key
+			sendMessage $ if ok then SUCCESS else FAILURE
 		REMOVE key -> do
 			ok <- removeKeyFile key
 			sendMessage $ if ok then SUCCESS else FAILURE
 		PUT key -> do
-			have <- checkPresent key
+			have <- checkContentPresent key
 			if have
 				then sendMessage ALREADY_HAVE
 				else do
@@ -241,6 +251,7 @@ instance Proto.Sendable Message where
 	formatMessage (AUTH uuid authtoken) = ["AUTH", Proto.serialize uuid, Proto.serialize authtoken]
 	formatMessage (AUTH_SUCCESS uuid) = ["AUTH-SUCCESS",  Proto.serialize uuid]
 	formatMessage AUTH_FAILURE = ["AUTH-FAILURE"]
+	formatMessage (CHECKPRESENT key) = ["CHECKPRESENT", Proto.serialize key]
 	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]
@@ -255,6 +266,7 @@ instance Proto.Receivable Message where
 	parseCommand "AUTH" = Proto.parse2 AUTH
 	parseCommand "AUTH-SUCCESS" = Proto.parse1 AUTH_SUCCESS
 	parseCommand "AUTH-FAILURE" = Proto.parse0 AUTH_FAILURE
+	parseCommand "CHECKPRESENT" = Proto.parse1 CHECKPRESENT
 	parseCommand "REMOVE" = Proto.parse1 REMOVE
 	parseCommand "GET" = Proto.parse2 GET
 	parseCommand "PUT" = Proto.parse1 PUT