From 4d2cd58ee5a891a517b386c555d032722cc4d97b Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 17 Dec 2020 13:46:34 -0400
Subject: [PATCH] provide missing remote actions for importree only remote

Ah, it seemed too easy before when I was implementing importrree only,
and it was because all the key-based actions needed to be handled too.

Mostly copied from isexport, and this works. It does seem that
an import remote could use retrieveExportWithContentIdentifier
rather than retrieveExport, and checkPresentExportWithContentIdentifier
rather than checkPresentExport, which would both be more accurate.
---
 Remote/Helper/ExportImport.hs | 120 ++++++++++++++++++++--------------
 1 file changed, 72 insertions(+), 48 deletions(-)

diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs
index 27b63bab4d..e755604f1e 100644
--- a/Remote/Helper/ExportImport.hs
+++ b/Remote/Helper/ExportImport.hs
@@ -106,7 +106,7 @@ adjustExportImport rmt rs = do
 	case (exportTree (config rmt), importTree (config rmt)) of
 		(True, True) -> isimport dbv =<< isexport dbv rmt
 		(True, False) -> notimport =<< isexport dbv rmt
-		(False, True) -> notexport =<< isimport dbv rmt
+		(False, True) -> notexport =<< isimportonly dbv rmt
 		(False, False) -> notimport =<< notexport rmt
   where
 	notexport r = return $ r
@@ -122,54 +122,7 @@ adjustExportImport rmt rs = do
 			{ importSupported = importUnsupported
 			}
 		}
-	
-	isimport dbv r = do
-		ciddbv <- prepciddb
-
-		let keycids k = do
-			db <- getciddb ciddbv
-			liftIO $ ContentIdentifier.getContentIdentifiers db rs k
 
-		let checkpresent k loc = 
-			checkPresentExportWithContentIdentifier
-				(importActions r)
-				k loc 
-				=<< keycids k
-
-		return $ r
-			{ exportActions = (exportActions r)
-				{ storeExport = \f k loc p -> do
-					db <- getciddb ciddbv
-					exportdb <- getexportdb r dbv
-					oldks <- liftIO $ Export.getExportTreeKey exportdb loc
-					oldcids <- liftIO $ concat
-						<$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks
-					newcid <- storeExportWithContentIdentifier (importActions r) f k loc oldcids p
-					withExclusiveLock gitAnnexContentIdentifierLock $ do
-						liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k
-						liftIO $ ContentIdentifier.flushDbQueue db
-					recordContentIdentifier rs newcid k
-				, removeExport = \k loc ->
-					removeExportWithContentIdentifier (importActions r) k loc
-						=<< keycids k
-				, removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r)
-				-- renameExport is optional, and the
-				-- remote's implementation may
-				-- lose modifications to the file
-				-- (by eg copying and then deleting)
-				-- so don't use it
-				, renameExport = \_ _ _ -> return Nothing
-				, checkPresentExport = checkpresent
-				}
-			, checkPresent = if appendonly r
-				then checkPresent r
-				else \k -> anyM (checkpresent k)
-					=<< getexportlocs r dbv k
-			, getInfo = do
-				is <- getInfo r
-				return (is++[("import", "yes")])
-			}
-	
 	isexport dbv r = ifM (isExportSupported r)
 		( isexport' dbv r
 		, notexport r
@@ -241,6 +194,77 @@ adjustExportImport rmt rs = do
 			is <- getInfo r
 			return (is++[("export", "yes"), ("exportedtree", unwords ts)])
 		}
+	
+	isimport dbv r = do
+		ciddbv <- prepciddb
+
+		let keycids k = do
+			db <- getciddb ciddbv
+			liftIO $ ContentIdentifier.getContentIdentifiers db rs k
+
+		let checkpresent k loc = 
+			checkPresentExportWithContentIdentifier
+				(importActions r)
+				k loc 
+				=<< keycids k
+
+		return $ r
+			{ exportActions = (exportActions r)
+				{ storeExport = \f k loc p -> do
+					db <- getciddb ciddbv
+					exportdb <- getexportdb r dbv
+					oldks <- liftIO $ Export.getExportTreeKey exportdb loc
+					oldcids <- liftIO $ concat
+						<$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks
+					newcid <- storeExportWithContentIdentifier (importActions r) f k loc oldcids p
+					withExclusiveLock gitAnnexContentIdentifierLock $ do
+						liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k
+						liftIO $ ContentIdentifier.flushDbQueue db
+					recordContentIdentifier rs newcid k
+				, removeExport = \k loc ->
+					removeExportWithContentIdentifier (importActions r) k loc
+						=<< keycids k
+				, removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r)
+				-- renameExport is optional, and the
+				-- remote's implementation may
+				-- lose modifications to the file
+				-- (by eg copying and then deleting)
+				-- so don't use it
+				, renameExport = \_ _ _ -> return Nothing
+				, checkPresentExport = checkpresent
+				}
+			, checkPresent = if appendonly r
+				then checkPresent r
+				else \k -> anyM (checkpresent k)
+					=<< getexportlocs r dbv k
+			, getInfo = do
+				is <- getInfo r
+				return (is++[("import", "yes")])
+			}
+	
+	isimportonly dbv r' = isimport dbv r' >>= \r -> return $ r
+		{ storeKey = \_ _ _ ->
+			giveup "remote is configured with importtree=yes and without exporttree=yes; cannot modify content stored on it"
+		, retrieveKeyFile = \k af dest p ->
+			let retrieveexport = retrieveKeyFileFromExport r dbv k af dest p
+			in if appendonly r
+				then retrieveKeyFile r k af dest p
+					`catchNonAsync` const retrieveexport
+				else retrieveexport
+		, retrieveKeyFileCheap = if appendonly r
+			then retrieveKeyFileCheap r
+			else Nothing
+		, removeKey = \_k -> giveup "dropping content from this remote is not supported because it is configured with importtree=yes and without exporttree=yes"
+		, lockContent = if appendonly r
+			then lockContent r
+			else Nothing
+		, checkPresent = if appendonly r
+			then checkPresent r
+			else \k -> anyM (checkPresentExport (exportActions r) k)
+				=<< getexportlocs r dbv k
+		, checkPresentCheap = False
+		, mkUnavailable = return Nothing
+		}
 
 	prepciddb = do
 		lcklckv <- liftIO newEmptyTMVarIO
-- 
2.30.2