38b9ebc5fd
Noticed that Semigroup instance of Map is not suitable to use
for MapLog. For example, it behaved like this:
ghci> parseTrustLog "foo 1 timestamp=10\nfoo 2 timestamp=11" <> parseTrustLog "foo X timestamp=12"
fromList [(UUID "foo",LogEntry {changed = VectorClock 11s, value = SemiTrusted})]
Which was wrong, it lost the newer DeadTrusted value.
Luckily, nothing used that Semigroup when operating on a MapLog. And this
provides a safe instance.
Sponsored-by: Graham Spencer 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 =
|
|
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')
|