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 04fc474d168e1857d4657dcdb1197a08bc22ce9d..4fddf43b511f2c3e7ffd10cee26edb3c798c0923 100644 (file)
--- 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 ec8284bedb7bcf13058c90a48aa842db4645d4ef..9d732f6a6e0bfdf19e6f4e6739d498132925931e 100644 (file)
--- 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 <id@joeyh.name>
+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>
  -
  - 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 555f7a22fb7cd68a7cd36dd7f695c0358745d7cb..959158466bffab447ce15c226d5fcd5601baf0b4 100644 (file)
--- 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 879082d7126bb0d8da8f8a2ef3ced453791de399..4cc9b56e5af3dd6dbe54073456d05f94d8f79204 100644 (file)
--- 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 b539ee6212b34a4e7982381ac7ff71fd714b2bab..5398bacdcbd09f1cd65a2ea80c44a127c52ad8c6 100644 (file)
--- 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 <id@joeyh.name>  Fri, 29 Dec 2023 11:52:06 -0400
 

diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 842a854831963f9df31a89a334d3c64617d55b7a..d98c1f95c0d2ee80e23dd0ce612c5b6da6eb742e 100644 (file)
--- 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 779d300ff9bdeb7a49bbdbfd1687fbc053269df4..bca9c9ffed4eb3bb86dae35226b4cb0f1fd3ee0f 100644 (file)
--- 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 545f0996b22463d02435b4ea60e12b619d6cdfa3..0a8ac45d9cc40f09761185926774dcbd4d593ec4 100644 (file)
--- 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 11bd80f76161b41d09c80d77fb4d7c85d1ac0691..8d58ae29bfd21e6a3d32a46e0b4e368d8a5c1aed 100644 (file)
--- 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 4fba771b1edc5f4d0e7338db19debc82b506fee3..7385eaedd53395e5607ee9d5ad0b0be0af0e5157 100644 (file)
--- 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 bcc24c72af485865a13f08f96e0db752e2d640e9..7bd71ad287d7edceed976010f2e9c90eadcb0d8b 100644 (file)
--- 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 263278189fd9e992cb3d859a93a4cbd834fac84e..a59fc740fe15a9defcf1ef11249ceb2e179124ed 100644 (file)
--- 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 cd7f2a522f42f369fabbd9124944f5e070dddb53..9f8c5f1df9584f47912f84025af9013cd7dbcf97 100644 (file)
--- 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 78820c0db5bb4d37cb7dad8cec14b3e2e2ba1299..e5564ce9890f29bfe6b864e0b539da4fd8445008 100644 (file)
--- 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 3d28a2389498bc067586aa77b90e44854361a0e0..fe7a71fb514438f7b602daf9f725d3b8a0125feb 100644 (file)
--- 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 83b364fb85f66a95eb419af6607535af6b6a8d2d..f48567eb00e83c5f602667bedd92eebc8aed34a7 100644 (file)
--- 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 a3e48085caccdd62225b7e4254b15e09648ff854..14a7aef1fcca768f7c9789ce62a74187384de178 100644 (file)
--- 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 afaf290306e25eb35e93d745e5040ef5d7f1ca8e..c83064ad7849cd62c0dbc3551b8b5aeac252da8d 100644 (file)
--- 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 180d522d04b679eba4cd24316678ece5029dd532..f7fe1f9199326ded070a0d10fb1e6e5d5759e8cc 100644 (file)
--- 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 f944f4fe436556c08ddfbbfb47d1f095885a151a..c76f4d4d02f2f244fd5e2e73698e2ea0f47fef82 100644 (file)
--- 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 a18f971b7156a0b7559d2723075216ea920e4dd5..5b86df46d8bd46702ff668db7395e7b893dccb10 100644 (file)
--- 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 7c2ad0c25a45c4563fd394fa9ae41d298efce923..6b9138b9816082211fb018bf65a9dd99358bce63 100644 (file)
--- 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)