f1ce15036f
This is most of the way there, but not quite working. The layout of migrate.tree/ needs to be changed to follow this approach. git log will list all the files in tree order, so the new layout needs to alternate old and new keys. Can that be done? git may not document tree order, or may not preserve it here. Alternatively, change to using git log --format=raw and extract the tree header from that, then use git diff --raw $tree:migrate.tree/old $tree:migrate.tree/new That will be a little more expensive, but only when there are lots of migrations. Sponsored-by: Joshua Antonishen on Patreon
140 lines
4.4 KiB
Haskell
140 lines
4.4 KiB
Haskell
{- git-annex export log (also used to log imports)
|
|
-
|
|
- Copyright 2017-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Logs.Export (
|
|
Exported,
|
|
mkExported,
|
|
ExportParticipants,
|
|
ExportChange(..),
|
|
getExport,
|
|
exportedTreeishes,
|
|
incompleteExportedTreeishes,
|
|
recordExportBeginning,
|
|
recordExportUnderway,
|
|
recordExport,
|
|
logExportExcluded,
|
|
getExportExcluded,
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import qualified Data.ByteString as B
|
|
|
|
import Annex.Common
|
|
import qualified Annex.Branch
|
|
import qualified Git
|
|
import Git.Sha
|
|
import Git.FilePath
|
|
import Logs
|
|
import Logs.Export.Pure
|
|
import Logs.MapLog
|
|
import Logs.File
|
|
import qualified Git.LsTree
|
|
import qualified Git.Tree
|
|
import Annex.UUID
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Data.Either
|
|
import Data.Char
|
|
|
|
-- | Get what's been exported to a special remote.
|
|
getExport :: UUID -> Annex [Exported]
|
|
getExport remoteuuid = nub . mapMaybe get . M.toList
|
|
. parseExportLogMap
|
|
<$> Annex.Branch.get exportLog
|
|
where
|
|
get (ep, exported)
|
|
| exportTo ep == remoteuuid = Just exported
|
|
| otherwise = Nothing
|
|
|
|
-- | Record the beginning of an export, to allow cleaning up from
|
|
-- interrupted exports.
|
|
--
|
|
-- This is called before any changes are made to the remote.
|
|
recordExportBeginning :: UUID -> Git.Ref -> Annex ()
|
|
recordExportBeginning remoteuuid newtree = do
|
|
c <- currentVectorClock
|
|
u <- getUUID
|
|
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
|
|
old <- fromMaybe (mkExported emptyTree [])
|
|
. M.lookup ep
|
|
. parseExportLogMap
|
|
<$> Annex.Branch.get exportLog
|
|
let new = updateIncompleteExportedTreeish old (nub (newtree:incompleteExportedTreeishes [old]))
|
|
Annex.Branch.change
|
|
(Annex.Branch.RegardingUUID [remoteuuid, u])
|
|
exportLog
|
|
(buildExportLog . changeMapLog c ep new . parseExportLog)
|
|
recordExportTreeish newtree
|
|
|
|
-- Graft a tree ref into the git-annex branch. This is done
|
|
-- to ensure that it's available later, when getting exported files
|
|
-- from the remote. Since that could happen in another clone of the
|
|
-- repository, the tree has to be kept available, even if it
|
|
-- doesn't end up being merged into the master branch.
|
|
recordExportTreeish :: Git.Ref -> Annex ()
|
|
recordExportTreeish t = void $
|
|
Annex.Branch.rememberTreeish t (asTopFilePath exportTreeGraftPoint)
|
|
|
|
-- | Record that an export to a special remote is under way.
|
|
--
|
|
-- This is called before an export begins uploading new files to the
|
|
-- remote, but after it's cleaned up any files that need to be deleted
|
|
-- from the old treeish.
|
|
--
|
|
-- Any entries in the log for the oldTreeish will be updated to the
|
|
-- newTreeish. This way, when multiple repositories are exporting to
|
|
-- the same special remote, there's no conflict as long as they move
|
|
-- forward in lock-step.
|
|
recordExportUnderway :: UUID -> ExportChange -> Annex ()
|
|
recordExportUnderway remoteuuid ec = do
|
|
c <- currentVectorClock
|
|
hereuuid <- getUUID
|
|
let ep = ExportParticipants { exportFrom = hereuuid, exportTo = remoteuuid }
|
|
let exported = mkExported (newTreeish ec) []
|
|
let ru = Annex.Branch.RegardingUUID [remoteuuid, hereuuid]
|
|
Annex.Branch.change ru exportLog $
|
|
buildExportLog
|
|
. changeMapLog c ep exported
|
|
. mapLogWithKey (updateForExportChange remoteuuid ec c hereuuid)
|
|
. parseExportLog
|
|
|
|
-- Record information about the export to the git-annex branch.
|
|
--
|
|
-- This is equivalent to recordExportBeginning followed by
|
|
-- recordExportUnderway, but without the ability to clean up from
|
|
-- interrupted exports.
|
|
recordExport :: UUID -> Git.Ref -> ExportChange -> Annex ()
|
|
recordExport remoteuuid tree ec = do
|
|
when (oldTreeish ec /= [tree]) $
|
|
recordExportTreeish tree
|
|
recordExportUnderway remoteuuid ec
|
|
|
|
logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a
|
|
logExportExcluded u a = do
|
|
logf <- fromRepo $ gitAnnexExportExcludeLog u
|
|
withLogHandle logf $ \logh -> do
|
|
a (writer logh)
|
|
where
|
|
writer logh = B.hPutStr logh
|
|
. flip B.snoc (fromIntegral (ord '\n'))
|
|
. Git.LsTree.formatLsTree
|
|
. Git.Tree.treeItemToLsTreeItem
|
|
|
|
getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem]
|
|
getExportExcluded u = do
|
|
logf <- fromRepo $ gitAnnexExportExcludeLog u
|
|
liftIO $ catchDefaultIO [] $ exportExcludedParser
|
|
<$> L.readFile (fromRawFilePath logf)
|
|
where
|
|
|
|
exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem]
|
|
exportExcludedParser = map Git.Tree.lsTreeItemToTreeItem
|
|
. rights
|
|
. map (Git.LsTree.parseLsTree (Git.LsTree.LsTreeLong False))
|
|
. L.split (fromIntegral $ ord '\n')
|