diff --git a/Annex/Import.hs b/Annex/Import.hs index a737e41515..e21a3d0ee2 100644 --- a/Annex/Import.hs +++ b/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 diff --git a/Git/LsTree.hs b/Git/LsTree.hs index f678727379..4a10a56b8d 100644 --- a/Git/LsTree.hs +++ b/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 -> [] diff --git a/Git/Tree.hs b/Git/Tree.hs index b81a7e6a74..5f6a2c138b 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -1,6 +1,6 @@ {- git trees - - - Copyright 2016 Joey Hess + - Copyright 2016-2019 Joey Hess - - 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' [] diff --git a/Types/Import.hs b/Types/Import.hs index 5cddabc217..2340e8c46d 100644 --- a/Types/Import.hs +++ b/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