From: Joey Hess Date: Tue, 16 Jan 2024 18:29:10 +0000 (-0400) Subject: disk free checking for unsized keys X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~1^2~29^2~42 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=f6cf2dec4c3f03db1351d5e5ef5a042810a6e471;p=git-annex.git disk free checking for unsized keys Improve disk free space checking when transferring unsized keys to local git remotes. Since the size of the object file is known, can check that instead. Getting unsized keys from local git remotes does not check the actual object size. It would be harder to handle that direction because the size check is run locally, before anything involving the remote is done. So it doesn't know the size of the file on the remote. Also, transferring unsized keys to other remotes, including ssh remotes and p2p remotes don't do disk size checking for unsized keys. This would need a change in protocol. (It does seem like it would be possible to implement the same thing for directory special remotes though.) In some sense, it might be better to not ever do disk free checking for unsized keys, than to do it only sometimes. A user might notice this direction working and consider it a bug that the other direction does not. On the other hand, disk reserve checking is not implemented for most special remotes at all, and yet it is implemented for a few, which is also inconsistent, but best effort. And so doing this best effort seems to make some sense. Fundamentally, if the user wants the size to always be checked, they should not use unsized keys. Sponsored-by: Brock Spratlen on Patreon --- diff --git a/Annex/Content.hs b/Annex/Content.hs index 04fc474d16..4fddf43b51 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -279,9 +279,10 @@ lockContentUsing contentlocker key fallback a = withContentLockFile key $ \mlock {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches - the key and moves the file into the annex as a key's content. -} -getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool -getViaTmp rsp v key af action = checkDiskSpaceToGet key False $ - getViaTmpFromDisk rsp v key af action +getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmp rsp v key af sz action = + checkDiskSpaceToGet key sz False $ + getViaTmpFromDisk rsp v key af action {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk @@ -349,14 +350,14 @@ verificationOfContentFailed tmpfile = do - - Wen there's enough free space, runs the download action. -} -checkDiskSpaceToGet :: Key -> a -> Annex a -> Annex a -checkDiskSpaceToGet key unabletoget getkey = do +checkDiskSpaceToGet :: Key -> Maybe FileSize -> a -> Annex a -> Annex a +checkDiskSpaceToGet key sz unabletoget getkey = do tmp <- fromRepo (gitAnnexTmpObjectLocation key) e <- liftIO $ doesFileExist (fromRawFilePath tmp) alreadythere <- liftIO $ if e then getFileSize tmp else return 0 - ifM (checkDiskSpace Nothing key alreadythere True) + ifM (checkDiskSpace sz Nothing key alreadythere True) ( do -- The tmp file may not have been left writable when e $ thawContent tmp @@ -542,17 +543,18 @@ unlinkAnnex key = do secureErase obj liftIO $ removeWhenExistsWith R.removeLink obj -{- Runs an action to transfer an object's content. +{- Runs an action to transfer an object's content. The action is also + - passed the size of the object. - - In some cases, it's possible for the file to change as it's being sent. - If this happens, runs the rollback action and throws an exception. - The rollback action should remove the data that was transferred. -} -sendAnnex :: Key -> Annex () -> (FilePath -> Annex a) -> Annex a +sendAnnex :: Key -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a sendAnnex key rollback sendobject = go =<< prepSendAnnex' key where - go (Just (f, check)) = do - r <- sendobject f + go (Just (f, sz, check)) = do + r <- sendobject f sz check >>= \case Nothing -> return r Just err -> do @@ -571,9 +573,13 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex' key - Annex monad of the remote that is receiving the object, rather than - the sender. So it cannot rely on Annex state. -} -prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool)) +prepSendAnnex :: Key -> Annex (Maybe (FilePath, FileSize, Annex Bool)) prepSendAnnex key = withObjectLoc key $ \f -> do - let retval c = return $ Just (fromRawFilePath f, sameInodeCache f c) + let retval c cs = return $ Just + (fromRawFilePath f + , inodeCacheFileSize c + , sameInodeCache f cs + ) cache <- Database.Keys.getInodeCaches key if null cache -- Since no inode cache is in the database, this @@ -581,7 +587,7 @@ prepSendAnnex key = withObjectLoc key $ \f -> do -- change while the transfer is in progress, so -- generate an inode cache for the starting -- content. - then maybe (return Nothing) (retval . (:[])) + then maybe (return Nothing) (\fc -> retval fc [fc]) =<< withTSDelta (liftIO . genInodeCache f) -- Verify that the object is not modified. Usually this -- only has to check the inode cache, but if the cache @@ -589,19 +595,19 @@ prepSendAnnex key = withObjectLoc key $ \f -> do -- content. else withTSDelta (liftIO . genInodeCache f) >>= \case Just fc -> ifM (isUnmodified' key f fc cache) - ( retval (fc:cache) + ( retval fc (fc:cache) , return Nothing ) Nothing -> return Nothing -prepSendAnnex' :: Key -> Annex (Maybe (FilePath, Annex (Maybe String))) +prepSendAnnex' :: Key -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) prepSendAnnex' key = prepSendAnnex key >>= \case - Just (f, checksuccess) -> + Just (f, sz, checksuccess) -> let checksuccess' = ifM checksuccess ( return Nothing , return (Just "content changed while it was being sent") ) - in return (Just (f, checksuccess')) + in return (Just (f, sz, checksuccess')) Nothing -> return Nothing cleanObjectLoc :: Key -> Annex () -> Annex () diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs index ec8284bedb..9d732f6a6e 100644 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -1,6 +1,6 @@ {- git-annex low-level content functions - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -102,13 +102,13 @@ preserveGitMode _ _ = return True - to be downloaded from the free space. This way, we avoid overcommitting - when doing concurrent downloads. -} -checkDiskSpace :: Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool -checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (fromKey keySize key)) destdir key +checkDiskSpace :: Maybe FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace msz destdir key = checkDiskSpace' sz destdir key + where + sz = fromMaybe 1 (fromKey keySize key <|> msz) -{- Allows specifying the size of the key, if it's known, which is useful - - as not all keys know their size. -} -checkDiskSpace' :: Integer -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool -checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force) +checkDiskSpace' :: FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace' sz destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force) ( return True , do -- We can't get inprogress and free at the same @@ -123,7 +123,7 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRea dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case Just have -> do reserve <- annexDiskReserve <$> Annex.getGitConfig - let delta = need + reserve - have - alreadythere + inprogress + let delta = sz + reserve - have - alreadythere + inprogress let ok = delta <= 0 unless ok $ warning $ UnquotedString $ diff --git a/Annex/Import.hs b/Annex/Import.hs index 555f7a22fb..959158466b 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -841,7 +841,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec when ok $ logStatus k InfoPresent return (Just (k, ok)) - checkDiskSpaceToGet k Nothing $ + checkDiskSpaceToGet k Nothing Nothing $ notifyTransfer Download af $ download' (Remote.uuid remote) k af Nothing stdRetry $ \p' -> withTmp k $ downloader p' @@ -860,7 +860,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec recordcidkey cidmap cid k return sha Nothing -> error "internal" - checkDiskSpaceToGet tmpkey Nothing $ + checkDiskSpaceToGet tmpkey Nothing Nothing $ withTmp tmpkey $ \tmpfile -> tryNonAsync (downloader tmpfile) >>= \case Right sha -> return $ Just (loc, Left sha) @@ -896,7 +896,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec warning (UnquotedString (show e)) return Nothing let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) - checkDiskSpaceToGet tmpkey Nothing $ + checkDiskSpaceToGet tmpkey Nothing Nothing $ notifyTransfer Download af $ download' (Remote.uuid remote) tmpkey af Nothing stdRetry $ \p -> withTmp tmpkey $ \tmpfile -> diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 879082d712..4cc9b56e5a 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -80,7 +80,7 @@ download r key f d witness = Just StallDetectionDisabled -> go Nothing Just sd -> runTransferrer sd r key f d Download witness where - go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f $ \dest -> + go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest -> download' (Remote.uuid r) key f sd d (go' dest) witness go' dest p = verifiedAction $ Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc diff --git a/CHANGELOG b/CHANGELOG index b539ee6212..5398bacdcb 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -10,6 +10,8 @@ git-annex (10.20231228) UNRELEASED; urgency=medium run with eg --test-git-config annex.shared-sop-command=sqop * assistant: When generating a gpg secret key, avoid hardcoding the key algorithm and size. + * Improve disk free space checking when transferring unsized keys to + local git remotes. -- Joey Hess Fri, 29 Dec 2023 11:52:06 -0400 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 842a854831..d98c1f95c0 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -439,7 +439,7 @@ downloadWith canadd addunlockedmatcher downloader dummykey u url file = - the returned location. -} downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe (RawFilePath, Backend)) downloadWith' downloader dummykey u url file = - checkDiskSpaceToGet dummykey Nothing $ do + checkDiskSpaceToGet dummykey Nothing Nothing $ do backend <- chooseBackend file tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey let t = (Transfer.Transfer Transfer.Download u (fromKey id dummykey)) diff --git a/Command/Export.hs b/Command/Export.hs index 779d300ff9..bca9c9ffed 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -304,7 +304,7 @@ performExport r db ek af contentsha loc allfilledvar = do alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc - sendAnnex ek rollback $ \f -> + sendAnnex ek rollback $ \f _sz -> Remote.action $ storer f ek loc pm , do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 545f0996b2..0a8ac45d9c 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -195,7 +195,7 @@ performRemote key afile backend numcopies remote = let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop) cleanup cleanup `after` a tmp - getfile tmp = ifM (checkDiskSpace (Just (P.takeDirectory tmp)) key 0 True) + getfile tmp = ifM (checkDiskSpace Nothing (Just (P.takeDirectory tmp)) key 0 True) ( ifM (getcheap tmp) ( return (Just (Right UnVerified)) , ifM (Annex.getRead Annex.fast) diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 11bd80f761..8d58ae29bf 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -28,7 +28,7 @@ start :: (SeekInput, Key) -> CommandStart start (_, key) = fieldTransfer Download key $ \_p -> do -- This matches the retrievalSecurityPolicy of Remote.Git let rsp = RetrievalAllKeysSecure - ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) go) + ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) Nothing go) ( do logStatus key InfoPresent _ <- quiesce True diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 4fba771b1e..7385eaedd5 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -128,7 +128,7 @@ perform src key = do , giveup "failed" ) where - move = checkDiskSpaceToGet key False $ + move = checkDiskSpaceToGet key Nothing False $ moveAnnex key (AssociatedFile Nothing) src cleanup :: Key -> CommandCleanup diff --git a/Command/SendKey.hs b/Command/SendKey.hs index bcc24c72af..7bd71ad287 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -32,7 +32,8 @@ start (_, key) = do <$> getField "RsyncOptions" ifM (inAnnex key) ( fieldTransfer Upload key $ \_p -> - sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts) + sendAnnex key rollback $ \f _sz -> + liftIO $ rsyncServerSend (map Param opts) f , do warning "requested key is not present" liftIO exitFailure diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 263278189f..a59fc740fe 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -36,7 +36,7 @@ perform file key = do -- the file might be on a different filesystem, so moveFile is used -- rather than simply calling moveAnnex; disk space is also -- checked this way. - ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key (AssociatedFile Nothing) $ \dest -> unVerified $ + ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key (AssociatedFile Nothing) Nothing $ \dest -> unVerified $ if dest /= file then liftIO $ catchBoolIO $ do moveFile file dest diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index cd7f2a522f..9f8c5f1df9 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -296,7 +296,7 @@ test runannex mkr mkk = Just b -> case Types.Backend.verifyKeyContent b of Nothing -> return True Just verifier -> verifier k (serializeKey' k) - get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> + get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) @@ -370,13 +370,13 @@ testUnavailable runannex mkr mkk = , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> - logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> + logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of Nothing -> return False - Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> + Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> unVerified $ isRight <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) ] diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 78820c0db5..e5564ce989 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -63,7 +63,7 @@ toPerform key file remote = go Upload file $ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ download' (uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file $ \t -> + logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file Nothing $ \t -> tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case Right v -> return (True, v) Left e -> do diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 3d28a23894..fe7a71fb51 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -50,7 +50,7 @@ start = do return True | otherwise = notifyTransfer direction file $ download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do + logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs index 83b364fb85..f48567eb00 100644 --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -55,7 +55,7 @@ start = do -- so caller is responsible for doing notification -- and for retrying, and updating location log, -- and stall canceling. - let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do + let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) in download' (Remote.uuid remote) key file Nothing noRetry go noNotification @@ -72,7 +72,7 @@ start = do runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = notifyTransfer Download file $ download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do + logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) diff --git a/P2P/Annex.hs b/P2P/Annex.hs index a3e48085ca..14a7aef1fc 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -64,7 +64,7 @@ runLocal runst runner a = case a of let fallback = runner (sender mempty (return Invalid)) v <- tryNonAsync $ prepSendAnnex k case v of - Right (Just (f, checkchanged)) -> proceed $ do + Right (Just (f, _sz, checkchanged)) -> proceed $ do -- alwaysUpload to allow multiple uploads of the same key. let runtransfer ti = transfer alwaysUpload k af Nothing $ \p -> sinkfile f o checkchanged sender p ti @@ -79,7 +79,7 @@ runLocal runst runner a = case a of iv <- startVerifyKeyContentIncrementally DefaultVerify k let runtransfer ti = Right <$> transfer download' k af Nothing (\p -> - logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp -> + logStatusAfter k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp -> storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti) let fallback = return $ Left $ ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" diff --git a/Remote/Directory.hs b/Remote/Directory.hs index afaf290306..c83064ad78 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -228,7 +228,7 @@ checkDiskSpaceDirectory d k = do (\a b -> deviceID a == deviceID b) <$> R.getSymbolicLinkStatus d <*> R.getSymbolicLinkStatus annexdir - checkDiskSpace (Just d) k 0 samefilesystem + checkDiskSpace Nothing (Just d) k 0 samefilesystem {- Passed a temp directory that contains the files that should be placed - in the dest directory, moves it into place. Anything already existing diff --git a/Remote/Git.hs b/Remote/Git.hs index 180d522d04..f7fe1f9199 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -487,7 +487,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc let bwlimit = remoteAnnexBwLimit (gitconfig r) -- run copy from perspective of remote onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case - Just (object, check) -> do + Just (object, _sz, check) -> do let checksuccess = check >>= \case Just err -> giveup err Nothing -> return True @@ -545,7 +545,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate | otherwise = giveup "copying to non-ssh repo not supported" where copylocal Nothing = giveup "content not available" - copylocal (Just (object, check)) = do + copylocal (Just (object, sz, check)) = do -- The check action is going to be run in -- the remote's Annex, but it needs access to the local -- Annex monad's state. @@ -563,7 +563,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate let checksuccess = liftIO checkio >>= \case Just err -> giveup err Nothing -> return True - logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> + logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file (Just sz) $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> copier object (fromRawFilePath dest) key p' checksuccess verify ) diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index f944f4fe43..c76f4d4d02 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -16,6 +16,7 @@ import Types.Remote import Annex.Content import Messages.Progress import Utility.Metered +import Utility.Tuple import Types.NumCopies import Annex.Verify @@ -33,7 +34,7 @@ type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> store :: RemoteGitConfig -> ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex () store gc runner k af p = do - let sizer = KeySizer k (fmap (toRawFilePath . fst) <$> prepSendAnnex k) + let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k) let bwlimit = remoteAnnexBwLimit gc metered (Just p) sizer bwlimit $ \_ p' -> runner (P2P.put k af p') >>= \case diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index a18f971b71..5b86df46d8 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -222,7 +222,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr isencrypted = isEncrypted c -- chunk, then encrypt, then feed to the storer - storeKeyGen k p enc = sendAnnex k rollback $ \src -> + storeKeyGen k p enc = sendAnnex k rollback $ \src _sz -> displayprogress p k (Just src) $ \p' -> storeChunks (uuid baser) chunkconfig enck k src p' enc encr storer checkpresent diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 7c2ad0c25a..6b9138b981 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -139,7 +139,7 @@ tahoeSetup _ mu _ c _ = do missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex () -store rs hdl k _f _p = sendAnnex k noop $ \src -> +store rs hdl k _f _p = sendAnnex k noop $ \src _sz -> parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe (giveup "tahoe failed to store content") (\cap -> storeCapability rs k cap)