From 4b048ca0428d63e6e010205218cabe4bd77c6f46 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 14 Apr 2021 15:11:00 -0400
Subject: [PATCH] directory CoW on store

Not for exports to directory yet though.
---
 CHANGELOG           |  3 +--
 Remote/Directory.hs | 56 ++++++++++++++++++++++++++-------------------
 2 files changed, 33 insertions(+), 26 deletions(-)

diff --git a/CHANGELOG b/CHANGELOG
index ecbf5e2881..c626a14f07 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -9,8 +9,7 @@ git-annex (8.20210331) UNRELEASED; urgency=medium
     exporttree remotes in some unusual circumstances.
   * fsck: When downloading content from a remote, if the content is able
     to be verified during the transfer, skip checksumming it a second time.
-  * directory: When cp supports reflinks, use it when getting content from
-    a directory special remote.
+  * directory: When cp supports reflinks, use it.
 
  -- Joey Hess <id@joeyh.name>  Thu, 01 Apr 2021 12:17:26 -0400
 
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index cbcbe368e5..23d130c22e 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -70,7 +70,7 @@ gen r u rc gc rs = do
 	let chunkconfig = getChunkConfig c
 	cow <- liftIO newCopyCoWTried
 	return $ Just $ specialRemote c
-		(storeKeyM dir chunkconfig)
+		(storeKeyM dir chunkconfig cow)
 		(retrieveKeyFileM dir chunkconfig cow)
 		(removeKeyM dir)
 		(checkPresentM dir chunkconfig)
@@ -169,43 +169,51 @@ storeDir d k = P.addTrailingPathSeparator $
 
 {- Check if there is enough free disk space in the remote's directory to
  - store the key. Note that the unencrypted key size is checked. -}
-storeKeyM :: RawFilePath -> ChunkConfig -> Storer
-storeKeyM d chunkconfig k c m = 
+storeKeyM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer
+storeKeyM d chunkconfig cow k c m = 
 	ifM (checkDiskSpaceDirectory d k)
-		( byteStorer (store d chunkconfig) k c m
+		( do
+			void $ liftIO $ tryIO $ createDirectoryUnder d tmpdir
+			store
 		, giveup "Not enough free disk space."
 		)
-
-checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool
-checkDiskSpaceDirectory d k = do
-	annexdir <- fromRepo gitAnnexObjectDir
-	samefilesystem <- liftIO $ catchDefaultIO False $ 
-		(\a b -> deviceID a == deviceID b)
-			<$> R.getFileStatus d
-			<*> R.getFileStatus annexdir
-	checkDiskSpace (Just d) k 0 samefilesystem
-
-store :: RawFilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex ()
-store d chunkconfig k b p = liftIO $ do
-	void $ tryIO $ createDirectoryUnder d tmpdir
-	case chunkconfig of
+  where
+	store = case chunkconfig of
 		LegacyChunks chunksize -> 
-			Legacy.store
+			let go _k b p = liftIO $ Legacy.store
 				(fromRawFilePath d)
 				chunksize
 				(finalizeStoreGeneric d)
 				k b p
 				(fromRawFilePath tmpdir)
 				(fromRawFilePath destdir)
-		_ -> do
-			let tmpf = tmpdir P.</> kf
-			meteredWriteFile p (fromRawFilePath tmpf) b
-			finalizeStoreGeneric d tmpdir destdir
-  where
+			in byteStorer go k c m
+		NoChunks ->
+			let go _k src p = do
+				(ok, _verification) <- fileCopier cow src tmpf k p (return True) NoVerify
+				unless ok $ giveup "failed to copy file to remote"
+				liftIO $ finalizeStoreGeneric d tmpdir destdir
+			in fileStorer go k c m
+		_ -> 
+			let go _k b p = liftIO $ do
+				meteredWriteFile p tmpf b
+				finalizeStoreGeneric d tmpdir destdir
+			in byteStorer go k c m
+	
 	tmpdir = P.addTrailingPathSeparator $ d P.</> "tmp" P.</> kf
+	tmpf = fromRawFilePath tmpdir </> fromRawFilePath kf
 	kf = keyFile k
 	destdir = storeDir d k
 
+checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool
+checkDiskSpaceDirectory d k = do
+	annexdir <- fromRepo gitAnnexObjectDir
+	samefilesystem <- liftIO $ catchDefaultIO False $ 
+		(\a b -> deviceID a == deviceID b)
+			<$> R.getFileStatus d
+			<*> R.getFileStatus annexdir
+	checkDiskSpace (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
  - in the dest directory will be deleted. File permissions will be locked
-- 
2.30.2