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

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))

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

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)

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

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

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

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

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))
 	]

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

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))

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))