add ALREADY-HAVE response to PUT

This commit is contained in:
Joey Hess 2016-11-17 21:37:49 -04:00
parent 47b7028d7c
commit 2b33452bd8
No known key found for this signature in database
GPG key ID: C910D9222512E3C7

View file

@ -47,6 +47,7 @@ data Message
| GET Offset Key | GET Offset Key
| PUT Key | PUT Key
| PUT_FROM Offset | PUT_FROM Offset
| ALREADY_HAVE
| SUCCESS | SUCCESS
| FAILURE | FAILURE
| DATA Len -- followed by bytes | DATA Len -- followed by bytes
@ -74,6 +75,8 @@ data ProtoF next
-- content been transferred. -- content been transferred.
| CheckAuthToken UUID AuthToken (Bool -> next) | CheckAuthToken UUID AuthToken (Bool -> next)
| SetPresent Key UUID next | SetPresent Key UUID next
| CheckPresent Key (Bool -> next)
-- ^ Checks if the whole content of the key is locally present.
deriving (Functor) deriving (Functor)
type Proto = Free ProtoF 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 (WriteKeyFile _ _ _ _ next)) ms = runPure (next True) ms
runPure (Free (CheckAuthToken _ _ 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 (SetPresent _ _ next)) ms = runPure next ms
runPure (Free (CheckPresent _ next)) ms = runPure (next False) ms
protoDump :: [(String, Maybe Message)] -> String protoDump :: [(String, Maybe Message)] -> String
protoDump = unlines . map protoDump' protoDump = unlines . map protoDump'
@ -121,6 +125,7 @@ put key = do
r <- getMessage r <- getMessage
case r of case r of
PUT_FROM offset -> sendContent key offset PUT_FROM offset -> sendContent key offset
ALREADY_HAVE -> return True
_ -> do _ -> do
sendMessage (PROTO_ERROR "expected PUT_FROM") sendMessage (PROTO_ERROR "expected PUT_FROM")
return False return False
@ -161,9 +166,13 @@ serve myuuid = go Nothing
authed _theiruuid r = case r of authed _theiruuid r = case r of
PUT key -> do PUT key -> do
ok <- receiveContent key PUT_FROM have <- checkPresent key
when ok $ if have
setPresent key myuuid then sendMessage ALREADY_HAVE
else do
ok <- receiveContent key PUT_FROM
when ok $
setPresent key myuuid
-- setPresent not called because the peer may have -- setPresent not called because the peer may have
-- requested the data but not permanatly stored it. -- requested the data but not permanatly stored it.
GET offset key -> void $ sendContent key offset 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 (GET offset key) = ["GET", Proto.serialize offset, Proto.serialize key]
formatMessage (PUT key) = ["PUT", Proto.serialize key] formatMessage (PUT key) = ["PUT", Proto.serialize key]
formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset]
formatMessage ALREADY_HAVE = ["ALREADY-HAVE"]
formatMessage SUCCESS = ["SUCCESS"] formatMessage SUCCESS = ["SUCCESS"]
formatMessage FAILURE = ["FAILURE"] formatMessage FAILURE = ["FAILURE"]
formatMessage (DATA leng) = ["DATA", Proto.serialize leng] formatMessage (DATA leng) = ["DATA", Proto.serialize leng]
@ -229,6 +239,7 @@ instance Proto.Receivable Message where
parseCommand "GET" = Proto.parse2 GET parseCommand "GET" = Proto.parse2 GET
parseCommand "PUT" = Proto.parse1 PUT parseCommand "PUT" = Proto.parse1 PUT
parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM
parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE
parseCommand "SUCCESS" = Proto.parse0 SUCCESS parseCommand "SUCCESS" = Proto.parse0 SUCCESS
parseCommand "FAILURE" = Proto.parse0 FAILURE parseCommand "FAILURE" = Proto.parse0 FAILURE
parseCommand "DATA" = Proto.parse1 DATA parseCommand "DATA" = Proto.parse1 DATA