initial try at using storeExportWithContentIdentifier

Untested, and I'm not sure about the locking of the ContentIdentifier db.

Annex/LockFile.hs

@@ -14,6 +14,7 @@ module Annex.LockFile (
 	fromLockCache,
 	withSharedLock,
 	withExclusiveLock,
+	takeExclusiveLock,
 	tryExclusiveLock,
 ) where
 
@@ -77,11 +78,18 @@ withSharedLock getlockfile a = debugLocks $ do
 {- Runs an action with an exclusive lock held. If the lock is already
  - held, blocks until it becomes free. -}
 withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a
-withExclusiveLock getlockfile a = debugLocks $ do
+withExclusiveLock getlockfile a = bracket
+	(takeExclusiveLock getlockfile)
+	(liftIO . dropLock)
+	(const a)
+
+{- Takes an exclusive lock, blocking until it's free. -}
+takeExclusiveLock :: (Git.Repo -> FilePath) -> Annex LockHandle
+takeExclusiveLock getlockfile = debugLocks $ do
 	lockfile <- fromRepo getlockfile
 	createAnnexDirectory $ takeDirectory lockfile
 	mode <- annexFileMode
-	bracket (lock mode lockfile) (liftIO . dropLock) (const a)
+	lock mode lockfile
   where
 #ifndef mingw32_HOST_OS
 	lock mode = noUmask mode . lockExclusive (Just mode)

Database/ContentIdentifier.hs

@@ -20,6 +20,7 @@ module Database.ContentIdentifier (
 	closeDb,
 	flushDbQueue,
 	recordContentIdentifier,
+	getContentIdentifiers,
 	getContentIdentifierKeys,
 	ContentIdentifiersId,
 ) where
@@ -82,11 +83,8 @@ recordContentIdentifier h u cid k = queueDb h $ do
 
 getContentIdentifiers :: ContentIdentifierHandle -> UUID -> Key -> IO [ContentIdentifier]
 getContentIdentifiers (ContentIdentifierHandle h) u k = H.queryDbQueue h $ do
-	l <- selectList
+	l <- selectList [ContentIdentifiersKey ==. toSKey k] []
-		[ ContentIdentifiersCid ==. cid
+	return $ map (contentIdentifiersCid . entityVal) l
-		, ContentIdentifiersKey ==. toSKey k
-		] []
-	return $ map (ContentIdentifiersCid . entityVal) l
 
 getContentIdentifierKeys :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> IO [Key]
 getContentIdentifierKeys (ContentIdentifierHandle h) u cid = 

Database/Export.hs

@@ -163,9 +163,9 @@ getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
  - Note that this does not see recently queued changes.
  -}
 getExportedKey :: ExportHandle -> ExportLocation -> IO [Key]
-getExportedKey ExportHandle h _) el = H.queryDbQueue h $ do
+getExportedKey (ExportHandle h _) el = H.queryDbQueue h $ do
 	l <- selectList [ExportedFile ==. ef] []
-	return $ map (fromSKey . exportedKey . entityVal) l
+	return $ map (fromIKey . exportedKey . entityVal) l
   where
 	ef = toSFilePath (fromExportLocation el)
 

Remote/Helper/ExportImport.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
 
 module Remote.Helper.ExportImport where
 
@@ -15,9 +15,11 @@ import Types.Backend
 import Types.Key
 import Backend
 import Remote.Helper.Encryptable (isEncrypted)
-import Database.Export
+import qualified Database.Export as Export
+import qualified Database.ContentIdentifier as ContentIdentifier
 import Annex.Export
 import Annex.Import
+import Annex.LockFile
 import Config
 import Git.Types (fromRef)
 import Logs.Export
@@ -91,51 +93,81 @@ adjustExportImportRemoteType rt = rt { setup = setup' }
 					then giveup "cannot enable importtree=yes without also enabling exporttree=yes"
 					else setup rt st mu cp c gc
 
--- | If the remote is importSupported, and importtree=yes, adjust the
+-- | Adjust a remote to support exporttree=yes and importree=yes.
--- remote to be an import.
 --
--- (This relies on all import remotes also being export remotes,
+-- Note that all remotes with importree=yes also have exporttree=yes.
--- so adjustExportable will adjust the remote actions to use the
+adjustExportImport :: Remote -> Annex Remote
--- exported/imported tree.)
+adjustExportImport r = case M.lookup "exporttree" (config r) of
-adjustImportable :: Remote -> Annex Remote
+	Nothing -> return $ notexport r
-adjustImportable r
+	Just c -> case yesNo c of
-	| importTree (config r) =
+		Just True -> ifM (isExportSupported r)
-		ifM (isExportSupported r)
+			( do
-			( return r
+				exportdb <- Export.openDb (uuid r)
-			, notimport
+				r' <- isexport exportdb
+				if importTree (config r)
+					then isimport r' exportdb
+					else return r'
+			, return $ notexport r
 			)
-	| otherwise = notimport
+		Just False -> return $ notexport r
+		Nothing -> do
+			warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"
+			return $ notexport r
   where
-	notimport = return $ r 
+	notexport r' = notimport r'
+		{ exportActions = exportUnsupported
+		, remotetype = (remotetype r')
+			{ exportSupported = exportUnsupported
+			}
+		}
+	
+	notimport r' = r'
 		{ importActions = importUnsupported
-		, remotetype = (remotetype r)
+		, remotetype = (remotetype r')
 			{ importSupported = importUnsupported
 			}
 		}
 	
--- | If the remote is exportSupported, and exporttree=yes, adjust the
+	isimport r' exportdb = do
--- remote to be an export.
+		lcklckv <- liftIO newEmptyTMVarIO
-adjustExportable :: Remote -> Annex Remote
+		dbtv <- liftIO newEmptyTMVarIO
-adjustExportable r = case M.lookup "exporttree" (config r) of
+		let store f k loc p = do
-	Nothing -> notexport
+			-- Only open the database once it's needed, since
-	Just c -> case yesNo c of
+			-- we have to take an exclusive write lock.
-		Just True -> ifM (isExportSupported r)
+			-- The write lock will remain held while the
-			( isexport
+			-- process is running.
-			, notexport
+			db <- liftIO (atomically (tryReadTMVar dbtv)) >>= \case
+				Just (db, _lck) -> return db
+				-- let only one thread take the lock
+				Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ())
+					( do
+						lck <- takeExclusiveLock gitAnnexContentIdentifierLock
+						db <- ContentIdentifier.openDb
+						liftIO $ atomically (putTMVar dbtv (db, lck))
+						return db
+					-- loser waits for winner to open
+					-- the db and can then also use its
+					-- handle
+					, liftIO $ fst <$> atomically (readTMVar dbtv)
 					)
-		Just False -> notexport
+
-		Nothing -> do
+			ks <- liftIO $ Export.getExportedKey exportdb loc
-			warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"
+			oldcids <- liftIO $ concat
-			notexport
+				<$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) ks
-  where
+			storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case
-	notexport = return $ r 
+				Nothing -> return False
-		{ exportActions = exportUnsupported
+				Just newcid -> do
-		, remotetype = (remotetype r)
+					liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k
-			{ exportSupported = exportUnsupported
+					-- TODO update git-annex branch
+					return True
+
+		return $ r'
+			{ exportActions = (exportActions r')
+				{ storeExport = store
 				}
 			}
-	isexport = do
+
-		db <- openDb (uuid r)
+	isexport db = do
 		updateflag <- liftIO $ newTVarIO Nothing
 
 		-- When multiple threads run this, all except the first
@@ -163,13 +195,13 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 		let getexportlocs = \k -> do
 			bracket startupdateonce doneupdateonce $ \updatenow ->
 				when updatenow $
-					updateExportTreeFromLog db >>= \case
+					Export.updateExportTreeFromLog db >>= \case
-						ExportUpdateSuccess -> return ()
+						Export.ExportUpdateSuccess -> return ()
-						ExportUpdateConflict -> do
+						Export.ExportUpdateConflict -> do
 							warnExportConflict r
 							liftIO $ atomically $
 								writeTVar exportinconflict True
-			liftIO $ getExportTree db k
+			liftIO $ Export.getExportTree db k
 
 		return $ r
 			-- Storing a key on an export could be implemented,

Remote/List.hs

@@ -106,10 +106,7 @@ remoteGen m t g = do
 	let c = fromMaybe M.empty $ M.lookup u m
 	generate t g u c gc >>= \case
 		Nothing -> return Nothing
-		Just r -> do
+		Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r))
-			r' <- adjustImportable (adjustReadOnly (addHooks r))
-			r'' <- adjustExportable r'
-			return $ Just r''
 
 {- Updates a local git Remote, re-reading its git config. -}
 updateRemote :: Remote -> Annex (Maybe Remote)

doc/todo/import_tree.mdwn

@@ -10,12 +10,17 @@ this.
 
 ## implementation notes
 
+* Should the ContentIdentifier db be multiwriter? It would simplify
+  the situation with the long-lived lock of it in adjustExportImport
+
+* fix TODO in adjustExportImport
+
+* Test export to importtree=yes remote and make sure it uses 
+  storeExportWithContentIdentifier correctly.
+
 * Need to support annex-tracking-branch configuration, which documentation
   says makes git-annex sync and assistant do imports.
 
-* export needs to use storeExportWithContentIdentifierM for importtree=yes
-  remotes
-
 * Database.ContentIdentifier needs a way to update the database with
   information coming from the git-annex branch. This will allow multiple
   clones to import from the same remote, and share content identifier