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

incremental checksum on upload to ssh or p2p

Browse source
This commit is contained in:
Joey Hess 2021-02-10 12:41:05 -04:00
parent 94f6210b68
commit 4b63e932f3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 20 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

4
CHANGELOG
View file

@ -24,8 +24,8 @@ git-annex (8.20210128) UNRELEASED; urgency=medium
* Include libkqueue.h file needed to build the assistant on BSDs. * Include libkqueue.h file needed to build the assistant on BSDs.
* Tahoe: Avoid verifying hash after download, since tahoe does sufficient * Tahoe: Avoid verifying hash after download, since tahoe does sufficient
verification itself. verification itself.
* Checksum as content is received from a remote git-annex repository, * Checksum as content is received from a remote git-annex repository
rather than doing it in a second pass. over ssh/p2p protocols, rather than doing it in a second pass.
-- Joey Hess <id@joeyh.name> Thu, 28 Jan 2021 12:34:32 -0400 -- Joey Hess <id@joeyh.name> Thu, 28 Jan 2021 12:34:32 -0400

8
P2P/Annex.hs
View file

@ -24,6 +24,7 @@ import Logs.Location
import Types.NumCopies import Types.NumCopies
import Utility.Metered import Utility.Metered
import Types.Backend (IncrementalVerifier(..)) import Types.Backend (IncrementalVerifier(..))
import Backend
import Control.Monad.Free import Control.Monad.Free
import Control.Concurrent.STM import Control.Concurrent.STM
@ -76,10 +77,11 @@ runLocal runst runner a = case a of
-- Remote.P2P and Remote.Git. -- Remote.P2P and Remote.Git.
let rsp = RetrievalAllKeysSecure let rsp = RetrievalAllKeysSecure
v <- tryNonAsync $ do v <- tryNonAsync $ do
iv <- startVerifyKeyContentIncrementally DefaultVerify k
let runtransfer ti = let runtransfer ti =
Right <$> transfer download' k af Nothing (\p -> Right <$> transfer download' k af Nothing (\p ->
logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp -> logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp ->
storefile (fromRawFilePath tmp) o l getb Nothing validitycheck p ti) storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti)
let fallback = return $ Left $ let fallback = return $ Left $
ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"
checktransfer runtransfer fallback checktransfer runtransfer fallback
@ -87,10 +89,10 @@ runLocal runst runner a = case a of
Left e -> return $ Left $ ProtoFailureException e Left e -> return $ Left $ ProtoFailureException e
Right (Left e) -> return $ Left e Right (Left e) -> return $ Left e
Right (Right ok) -> runner (next ok) Right (Right ok) -> runner (next ok)
StoreContentTo dest incrementalverifier o l getb validitycheck next -> do StoreContentTo dest iv o l getb validitycheck next -> do
v <- tryNonAsync $ do v <- tryNonAsync $ do
let runtransfer ti = Right let runtransfer ti = Right
<$> storefile dest o l getb incrementalverifier validitycheck nullMeterUpdate ti <$> storefile dest o l getb iv validitycheck nullMeterUpdate ti
let fallback = return $ Left $ let fallback = return $ Left $
ProtoFailureMessage "transfer failed" ProtoFailureMessage "transfer failed"
checktransfer runtransfer fallback checktransfer runtransfer fallback

25
P2P/Protocol.hs
View file

@ -17,8 +17,9 @@ import qualified Utility.SimpleProtocol as Proto
import Types (Annex) import Types (Annex)
import Types.Key import Types.Key
import Types.UUID import Types.UUID
import Types.Remote (Verification(..), unVerified) import Types.Remote (Verification(..))
import Types.Backend (IncrementalVerifier(..)) import Types.Backend (IncrementalVerifier(..))
import Types.Transfer
import Utility.AuthToken import Utility.AuthToken
import Utility.Applicative import Utility.Applicative
import Utility.PartialPrelude import Utility.PartialPrelude
@ -504,10 +505,9 @@ serveAuthed servermode myuuid = void $ serverLoop handler
then net $ sendMessage ALREADY_HAVE then net $ sendMessage ALREADY_HAVE
else do else do
let sizer = tmpContentSize key let sizer = tmpContentSize key
let storer = \o l b v -> unVerified $ let storer = storeContent key af
storeContent key af o l b v v <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM
(ok, _v) <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM when (observeBool v) $
when ok $
local $ setPresent key myuuid local $ setPresent key myuuid
return ServerContinue return ServerContinue
@ -533,12 +533,13 @@ sendContent key af offset@(Offset n) p = go =<< local (contentSize key)
checkSuccess checkSuccess
receiveContent receiveContent
:: Maybe Meter :: Observable t
=> Maybe Meter
-> MeterUpdate -> MeterUpdate
-> Local Len -> Local Len
-> (Offset -> Len -> Proto L.ByteString -> Proto (Maybe Validity) -> Local (Bool, Verification)) -> (Offset -> Len -> Proto L.ByteString -> Proto (Maybe Validity) -> Local t)
-> (Offset -> Message) -> (Offset -> Message)
-> Proto (Bool, Verification) -> Proto t
receiveContent mm p sizer storer mkmsg = do receiveContent mm p sizer storer mkmsg = do
Len n <- local sizer Len n <- local sizer
let p' = offsetMeterUpdate p (toBytesProcessed n) let p' = offsetMeterUpdate p (toBytesProcessed n)
@ -558,14 +559,14 @@ receiveContent mm p sizer storer mkmsg = do
net $ sendMessage (ERROR "expected VALID or INVALID") net $ sendMessage (ERROR "expected VALID or INVALID")
return Nothing return Nothing
else return Nothing else return Nothing
(ok, v) <- local $ storer offset len v <- local $ storer offset len
(net (receiveBytes len p')) (net (receiveBytes len p'))
validitycheck validitycheck
sendSuccess ok sendSuccess (observeBool v)
return (ok, v) return v
_ -> do _ -> do
net $ sendMessage (ERROR "expected DATA") net $ sendMessage (ERROR "expected DATA")
return (False, UnVerified) return observeFailure
checkSuccess :: Proto Bool checkSuccess :: Proto Bool
checkSuccess = do checkSuccess = do