mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

avoid P2P.Protocol defining instance Proto.Serializable AssociatedFile

Browse source 
It's got its own specific hacks, so it needs it own specific data type.
This commit is contained in:
Joey Hess 2020-12-09 13:46:42 -04:00
parent 004a4f5fb1
commit 7e25c643cf
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 20 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
P2P/Protocol.hs
View file

@ -2,7 +2,7 @@
- -
- See doc/design/p2p_protocol.mdwn - See doc/design/p2p_protocol.mdwn
- -
- Copyright 2016-2018 Joey Hess <id@joeyh.name> - Copyright 2016-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -53,6 +53,9 @@ defaultProtocolVersion = ProtocolVersion 0
maxProtocolVersion :: ProtocolVersion maxProtocolVersion :: ProtocolVersion
maxProtocolVersion = ProtocolVersion 1 maxProtocolVersion = ProtocolVersion 1
newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile
deriving (Show)
-- | Service as used by the connect message in gitremote-helpers(1) -- | Service as used by the connect message in gitremote-helpers(1)
data Service = UploadPack | ReceivePack data Service = UploadPack | ReceivePack
deriving (Show) deriving (Show)
@ -75,8 +78,8 @@ data Message
| LOCKCONTENT Key | LOCKCONTENT Key
| UNLOCKCONTENT | UNLOCKCONTENT
| REMOVE Key | REMOVE Key
| GET Offset AssociatedFile Key | GET Offset ProtoAssociatedFile Key
| PUT AssociatedFile Key | PUT ProtoAssociatedFile Key
| PUT_FROM Offset | PUT_FROM Offset
| ALREADY_HAVE | ALREADY_HAVE
| SUCCESS | SUCCESS
@ -154,7 +157,7 @@ instance Proto.Serializable Service where
deserialize "git-receive-pack" = Just ReceivePack deserialize "git-receive-pack" = Just ReceivePack
deserialize _ = Nothing deserialize _ = Nothing
-- | Since AssociatedFile is not the last thing in a protocol line, -- | Since ProtoAssociatedFile is not the last thing in a protocol line,
-- its serialization cannot contain any whitespace. This is handled -- its serialization cannot contain any whitespace. This is handled
-- by replacing whitespace with '%' (and '%' with '%%') -- by replacing whitespace with '%' (and '%' with '%%')
-- --
@ -162,11 +165,11 @@ instance Proto.Serializable Service where
-- to avoid any unusual characters that might cause problems when it's -- to avoid any unusual characters that might cause problems when it's
-- displayed to the user. -- displayed to the user.
-- --
-- These mungings are ok, because an AssociatedFile is only ever displayed -- These mungings are ok, because a ProtoAssociatedFile is only ever displayed
-- to the user and does not need to match a file on disk. -- to the user and does not need to match a file on disk.
instance Proto.Serializable AssociatedFile where instance Proto.Serializable ProtoAssociatedFile where
serialize (AssociatedFile Nothing) = "" serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = ""
serialize (AssociatedFile (Just af)) = serialize (ProtoAssociatedFile (AssociatedFile (Just af))) =
decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af
where where
esc '%' = "%%" esc '%' = "%%"
@ -175,9 +178,10 @@ instance Proto.Serializable AssociatedFile where
| otherwise = [c] | otherwise = [c]
deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of
[] -> Just (AssociatedFile Nothing) [] -> Just $ ProtoAssociatedFile $ AssociatedFile Nothing
f f
| isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f | isRelative f -> Just $ ProtoAssociatedFile $
AssociatedFile $ Just $ toRawFilePath f
| otherwise -> Nothing | otherwise -> Nothing
where where
deesc b [] = reverse b deesc b [] = reverse b
@ -349,14 +353,15 @@ remove key = do
get :: FilePath -> Key -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get :: FilePath -> Key -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
get dest key af m p = get dest key af m p =
receiveContent (Just m) p sizer storer (\offset -> GET offset af key) receiveContent (Just m) p sizer storer $ \offset ->
GET offset (ProtoAssociatedFile af) key
where where
sizer = fileSize dest sizer = fileSize dest
storer = storeContentTo dest storer = storeContentTo dest
put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool
put key af p = do put key af p = do
net $ sendMessage (PUT af key) net $ sendMessage (PUT (ProtoAssociatedFile af) key)
r <- net receiveMessage r <- net receiveMessage
case r of case r of
Just (PUT_FROM offset) -> sendContent key af offset p Just (PUT_FROM offset) -> sendContent key af offset p
@ -461,14 +466,14 @@ serveAuthed servermode myuuid = void $ serverLoop handler
ServeReadOnly -> do ServeReadOnly -> do
readonlyerror readonlyerror
return ServerContinue return ServerContinue
handler (PUT af key) = case servermode of handler (PUT (ProtoAssociatedFile af) key) = case servermode of
ServeReadWrite -> handleput af key ServeReadWrite -> handleput af key
ServeAppendOnly -> handleput af key ServeAppendOnly -> handleput af key
ServeReadOnly -> do ServeReadOnly -> do
readonlyerror readonlyerror
return ServerContinue return ServerContinue
handler (GET offset key af) = do handler (GET offset (ProtoAssociatedFile af) key) = do
void $ sendContent af key offset nullMeterUpdate void $ sendContent key af offset nullMeterUpdate
-- setPresent not called because the peer may have -- setPresent not called because the peer may have
-- requested the data but not permanently stored it. -- requested the data but not permanently stored it.
return ServerContinue return ServerContinue