buildImportTrees is fully working

buildImportCommit not yet tested

Annex/Import.hs

@@ -5,15 +5,22 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module Annex.Import (buildImportCommit) where
+module Annex.Import (buildImportCommit, buildImportTrees) where
 
 import Annex.Common
 import Types.Import
+import Types.Remote (uuid)
 import Git.Types
 import Git.Tree
-import Git.Branch
+import Git.Sha
 import Git.FilePath
+import qualified Git.Ref
+import qualified Git.Branch
+import qualified Annex
 import Annex.Link
+import Annex.LockFile
+import Logs.Export
+import Database.Export
 
 {- Builds a commit on top of a basecommit that reflects changes to the
  - content of a remote. When there are no changes to commit, returns Nothing.
@@ -22,50 +29,94 @@ import Annex.Link
  - builds a corresponding tree of git commits.
  -
  - After importing from a remote, exporting the same thing back to the
- - remote should be a no-op. So, the export log is updated to reflect the
- - imported tree.
+ - remote should be a no-op. So, the export log and database are
+ - updated to reflect the imported tree.
  -
  - The files are imported to the top of the git repository, unless a
  - subdir is specified, then the import will only affect the contents of
  - the subdir.
  -
  - This does not import any content from a remote. But since it needs the
- - Key of imported files to be known, its caller will have to download
+ - Key of imported files to be known, its caller will have to first download
  - new files in order to generate keys for them.
  -}
 buildImportCommit
-	:: Ref
-	-> Maybe FilePath
+	:: Remote
+	-> Ref
+	-> Maybe TopFilePath
 	-> ImportableContents Key
-	-> CommitMode
+	-> Git.Branch.CommitMode
 	-> String
-	-> Annex (Maybe Ref)
-buildImportCommit basecommit subdir importable commitmode commitmessage = do
-	go =<< buildImportTrees basetree importable
+	-> Annex (Either String (Maybe Ref))
+buildImportCommit remote basecommit subdir importable commitmode commitmessage =
+	inRepo (Git.Ref.tree basecommit) >>= \case
+		Nothing -> return $
+			Left $ "Cannot find tree for " ++ fromRef basecommit
+		Just basetree -> do
+			imported@(History finaltree _) <-
+				buildImportTrees basetree subdir importable
+			mkcommits basetree imported >>= \case
+				Nothing -> return (Right Nothing)
+				Just finalcommit -> do
+					updateexportdb finaltree
+					updateexportlog finaltree
+					return (Right (Just finalcommit))
   where
-	go (History importedtree hs) = do
-		parents <- mapM go hs
-		
-		inRepo $ commitTree commitmode commitmessage parents tree
+	mkcommits basetree (History importedtree hs) = do
+		parents <- catMaybes <$> mapM (mkcommits basetree) hs
+		if basetree == importedtree && null parents
+			then return Nothing
+			else do
+				commit <- inRepo $ Git.Branch.commitTree commitmode commitmessage parents importedtree
+				return (Just commit)
+	updateexportdb importedtree = 
+		withExclusiveLock (gitAnnexExportLock (uuid remote)) $ do
+			db <- openDb (uuid remote)
+			prevtree <- liftIO $ fromMaybe emptyTree
+				<$> getExportTreeCurrent db
+			when (importedtree /= prevtree) $ do
+				updateExportTree db prevtree importedtree
+				liftIO $ recordExportTreeCurrent db importedtree
+				-- TODO: addExportedLocation etc
+				liftIO $ flushDbQueue db
+	updateexportlog importedtree = do
+		old <- getExport (uuid remote)
+		recordExport (uuid remote) $ ExportChange
+			{ oldTreeish = exportedTreeishes old
+			, newTreeish = importedtree
+			}
 
 data History t = History t [History t]
+	deriving (Show)
 
-{- Builds a history of git trees reflecting the ImportableContents. -}
+{- Builds a history of git trees reflecting the ImportableContents.
+ -
+ - When a subdir is provided, imported tree is grafted into the basetree at
+ - that location, replacing any object that was there.
+ -}
 buildImportTrees
-	:: Maybe FilePath
+	:: Ref
+	-> Maybe TopFilePath
 	-> ImportableContents Key
 	-> Annex (History Sha)
-buildImportTrees subdir i = History
-	<$> go (importableContents i)
-	<*> mapM (buildImportTrees subdir basetree) (importableHistory i)
+buildImportTrees basetree msubdir importable = History
+	<$> (go (importableContents importable) =<< Annex.gitRepo)
+	<*> mapM (buildImportTrees basetree msubdir) (importableHistory importable)
   where
-	go ls = do
-		is <- mapM mktreeitem ls
-		inRepo $ recordTree (treeItemsToTree is)
+	go ls repo = withMkTreeHandle repo $ \hdl -> do
+		importtree <- liftIO . recordTree' hdl 
+			. treeItemsToTree
+			=<< mapM mktreeitem ls
+		case msubdir of
+			Nothing -> return importtree
+			Just subdir -> liftIO $ 
+				graftTree' importtree subdir basetree repo hdl
 	mktreeitem (loc, k) = do
 		let lf = fromImportLocation loc
-		let topf = asTopFilePath $ maybe lf (</> lf) subdir
+		let treepath = asTopFilePath lf
+		let topf = asTopFilePath $
+			maybe lf (\sd -> getTopFilePath sd </> lf) msubdir
 		relf <- fromRepo $ fromTopFilePath topf
 		symlink <- calcRepo $ gitAnnexLink relf k
 		linksha <- hashSymlink symlink
-		return $ TreeItem topf (fromTreeItemType TreeSymlink) linksha
+		return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha

Git/LsTree.hs

@@ -42,12 +42,12 @@ lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
 lsTree = lsTree' []
 
 lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
-lsTree' ps mode t repo = do
-	(l, cleanup) <- pipeNullSplit (lsTreeParams mode t ps) repo
+lsTree' ps lsmode t repo = do
+	(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
 	return (map parseLsTree l, cleanup)
 
 lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
-lsTreeParams mode r ps =
+lsTreeParams lsmode r ps =
 	[ Param "ls-tree"
 	, Param "--full-tree"
 	, Param "-z"
@@ -56,7 +56,7 @@ lsTreeParams mode r ps =
 	, File $ fromRef r
 	]
   where
-	recursiveparams = case mode of
+	recursiveparams = case lsmode of
 		LsTreeRecursive -> [ Param "-r" ]
 		LsTreeNonRecursive -> []
 

Git/Tree.hs

@@ -1,6 +1,6 @@
 {- git trees
  -
- - Copyright 2016 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,10 +12,13 @@ module Git.Tree (
 	TreeContent(..),
 	getTree,
 	recordTree,
+	recordTree',
 	TreeItem(..),
 	treeItemsToTree,
 	adjustTree,
 	graftTree,
+	graftTree',
+	withMkTreeHandle,
 	treeMode,
 ) where
 
@@ -245,14 +248,22 @@ graftTree
 	-> Repo
 	-> IO Sha
 graftTree subtree graftloc basetree repo =
-	withMkTreeHandle repo $
-		go basetree graftdirs
+	withMkTreeHandle repo $ graftTree' subtree graftloc basetree repo
+
+graftTree'
+	:: Sha
+	-> TopFilePath
+	-> Sha
+	-> Repo
+	-> MkTreeHandle
+	-> IO Sha
+graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs
   where
-	go tsha (topmostgraphdir:restgraphdirs) h = do
+	go tsha (topmostgraphdir:restgraphdirs) = do
 		Tree t <- getTree LsTree.LsTreeNonRecursive tsha repo
 		t' <- case partition isabovegraft t of
 			([], _) -> do
-				graft <- graftin h (topmostgraphdir:restgraphdirs)
+				graft <- graftin (topmostgraphdir:restgraphdirs)
 				return (graft:t)
 			-- normally there can only be one matching item
 			-- in the tree, but it's theoretically possible
@@ -264,16 +275,16 @@ graftTree subtree graftloc basetree repo =
 						| null restgraphdirs -> return $
 							RecordedSubTree tloc subtree []
 						| otherwise -> do
-							tsha'' <- go tsha' restgraphdirs h
+							tsha'' <- go tsha' restgraphdirs
 							return $ RecordedSubTree tloc tsha'' []
-					_ -> graftin h (topmostgraphdir:restgraphdirs)
+					_ -> graftin (topmostgraphdir:restgraphdirs)
 				return (newshas ++ rest)
-		mkTree h t'
-	go tsha [] h = return subtree
+		mkTree hdl t'
+	go _ [] = return subtree
 
 	isabovegraft i = beneathSubTree i graftloc || gitPath i == gitPath graftloc
 	
-	graftin h t = recordSubTree h $ graftin' t
+	graftin t = recordSubTree hdl $ graftin' t
 	graftin' [] = RecordedSubTree graftloc subtree []
 	graftin' (d:rest) 
 		| d == graftloc = graftin' []

Types/Import.hs

@@ -19,6 +19,9 @@ import Utility.FileSystemEncoding
  - location on the remote. -}
 type ImportLocation = ExportLocation
 
+mkImportLocation :: FilePath -> ImportLocation
+mkImportLocation = mkExportLocation
+
 fromImportLocation :: ImportLocation -> FilePath
 fromImportLocation = fromExportLocation