split out Logs.Export.Pure
This will allow Annex.Branch to use it, in transitions code. This commit was sponsored by Luke Shumaker on Patreon.
This commit is contained in:
Joey Hess
parent
e10ab30e3b
commit
a10cc80997
3 changed files with 119 additions and 77 deletions
|
|
@ -30,6 +30,7 @@ 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
|
||||
|
|
@ -37,45 +38,9 @@ import qualified Git.Tree
|
|||
import Annex.UUID
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as A
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A8
|
||||
import Data.ByteString.Builder
|
||||
import Data.Either
|
||||
import Data.Char
|
||||
|
||||
-- This constuctor is not itself exported to other modules, to enforce
|
||||
-- consistent use of exportedTreeishes.
|
||||
data Exported = Exported
|
||||
{ exportedTreeish :: Git.Ref
|
||||
, incompleteExportedTreeish :: [Git.Ref]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
mkExported :: Git.Ref -> [Git.Ref] -> Exported
|
||||
mkExported = Exported
|
||||
|
||||
-- | Get the list of exported treeishes.
|
||||
--
|
||||
-- If the list contains multiple items, there was an export conflict,
|
||||
-- and different trees were exported to the same special remote.
|
||||
exportedTreeishes :: [Exported] -> [Git.Ref]
|
||||
exportedTreeishes = nub . map exportedTreeish
|
||||
|
||||
-- | Treeishes that started to be exported, but were not finished.
|
||||
incompleteExportedTreeishes :: [Exported] -> [Git.Ref]
|
||||
incompleteExportedTreeishes = concatMap incompleteExportedTreeish
|
||||
|
||||
data ExportParticipants = ExportParticipants
|
||||
{ exportFrom :: UUID
|
||||
, exportTo :: UUID
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ExportChange = ExportChange
|
||||
{ oldTreeish :: [Git.Ref]
|
||||
, newTreeish :: Git.Ref
|
||||
}
|
||||
|
||||
-- | Get what's been exported to a special remote.
|
||||
getExport :: UUID -> Annex [Exported]
|
||||
getExport remoteuuid = nub . mapMaybe get . M.toList . simpleMap
|
||||
|
|
@ -95,11 +60,11 @@ recordExportBeginning remoteuuid newtree = do
|
|||
c <- currentVectorClock
|
||||
u <- getUUID
|
||||
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
|
||||
old <- fromMaybe (Exported emptyTree [])
|
||||
old <- fromMaybe (mkExported emptyTree [])
|
||||
. M.lookup ep . simpleMap
|
||||
. parseExportLog
|
||||
<$> Annex.Branch.get exportLog
|
||||
let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }
|
||||
let new = updateIncompleteExportedTreeish old (nub (newtree:incompleteExportedTreeishes [old]))
|
||||
Annex.Branch.change exportLog $
|
||||
buildExportLog
|
||||
. changeMapLog c ep new
|
||||
|
|
@ -128,18 +93,14 @@ recordExportTreeish t =
|
|||
recordExportUnderway :: UUID -> ExportChange -> Annex ()
|
||||
recordExportUnderway remoteuuid ec = do
|
||||
c <- currentVectorClock
|
||||
u <- getUUID
|
||||
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
|
||||
let exported = Exported (newTreeish ec) []
|
||||
hereuuid <- getUUID
|
||||
let ep = ExportParticipants { exportFrom = hereuuid, exportTo = remoteuuid }
|
||||
let exported = mkExported (newTreeish ec) []
|
||||
Annex.Branch.change exportLog $
|
||||
buildExportLog
|
||||
. changeMapLog c ep exported
|
||||
. M.mapWithKey (updateothers c u)
|
||||
. M.mapWithKey (updateForExportChange remoteuuid ec c hereuuid)
|
||||
. parseExportLog
|
||||
where
|
||||
updateothers c u ep le@(LogEntry _ exported@(Exported { exportedTreeish = t }))
|
||||
| u == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le
|
||||
| otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec })
|
||||
|
||||
-- Record information about the export to the git-annex branch.
|
||||
--
|
||||
|
|
@ -152,37 +113,6 @@ recordExport remoteuuid tree ec = do
|
|||
recordExportTreeish tree
|
||||
recordExportUnderway remoteuuid ec
|
||||
|
||||
parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported
|
||||
parseExportLog = parseMapLog exportParticipantsParser exportedParser
|
||||
|
||||
buildExportLog :: MapLog ExportParticipants Exported -> Builder
|
||||
buildExportLog = buildMapLog buildExportParticipants buildExported
|
||||
|
||||
buildExportParticipants :: ExportParticipants -> Builder
|
||||
buildExportParticipants ep =
|
||||
buildUUID (exportFrom ep) <> sep <> buildUUID (exportTo ep)
|
||||
where
|
||||
sep = charUtf8 ':'
|
||||
|
||||
exportParticipantsParser :: A.Parser ExportParticipants
|
||||
exportParticipantsParser = ExportParticipants
|
||||
<$> (toUUID <$> A8.takeWhile1 (/= ':'))
|
||||
<* A8.char ':'
|
||||
<*> (toUUID <$> A8.takeWhile1 (const True))
|
||||
|
||||
buildExported :: Exported -> Builder
|
||||
buildExported exported = go (exportedTreeish exported : incompleteExportedTreeish exported)
|
||||
where
|
||||
go [] = mempty
|
||||
go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]
|
||||
rref = byteString . Git.fromRef'
|
||||
|
||||
exportedParser :: A.Parser Exported
|
||||
exportedParser = Exported <$> refparser <*> many refparser
|
||||
where
|
||||
refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') )
|
||||
<* ((const () <$> A8.char ' ') <|> A.endOfInput)
|
||||
|
||||
logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a
|
||||
logExportExcluded u a = do
|
||||
logf <- fromRepo $ gitAnnexExportExcludeLog u
|
||||
|
|
|
|||
111
Logs/Export/Pure.hs
Normal file
111
Logs/Export/Pure.hs
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
{- git-annex export log (also used to log imports), pure operations
|
||||
-
|
||||
- Copyright 2017-2020 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Logs.Export.Pure (
|
||||
Exported,
|
||||
mkExported,
|
||||
updateExportedTreeish,
|
||||
updateIncompleteExportedTreeish,
|
||||
ExportParticipants(..),
|
||||
ExportChange(..),
|
||||
exportedTreeishes,
|
||||
incompleteExportedTreeishes,
|
||||
parseExportLog,
|
||||
buildExportLog,
|
||||
updateForExportChange,
|
||||
) where
|
||||
|
||||
import Annex.Common
|
||||
import qualified Git
|
||||
import Logs.MapLog
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as A
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A8
|
||||
import Data.ByteString.Builder
|
||||
|
||||
-- This constuctor is not itself exported to other modules, to enforce
|
||||
-- consistent use of exportedTreeishes.
|
||||
data Exported = Exported
|
||||
{ exportedTreeish :: Git.Ref
|
||||
, incompleteExportedTreeish :: [Git.Ref]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
mkExported :: Git.Ref -> [Git.Ref] -> Exported
|
||||
mkExported = Exported
|
||||
|
||||
updateExportedTreeish :: Exported -> Git.Ref -> Exported
|
||||
updateExportedTreeish ex t = ex { exportedTreeish = t }
|
||||
|
||||
updateIncompleteExportedTreeish :: Exported -> [Git.Ref] -> Exported
|
||||
updateIncompleteExportedTreeish ex t = ex { incompleteExportedTreeish = t }
|
||||
|
||||
-- | Get the list of exported treeishes.
|
||||
--
|
||||
-- If the list contains multiple items, there was an export conflict,
|
||||
-- and different trees were exported to the same special remote.
|
||||
exportedTreeishes :: [Exported] -> [Git.Ref]
|
||||
exportedTreeishes = nub . map exportedTreeish
|
||||
|
||||
-- | Treeishes that started to be exported, but were not finished.
|
||||
incompleteExportedTreeishes :: [Exported] -> [Git.Ref]
|
||||
incompleteExportedTreeishes = concatMap incompleteExportedTreeish
|
||||
|
||||
data ExportParticipants = ExportParticipants
|
||||
{ exportFrom :: UUID
|
||||
, exportTo :: UUID
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ExportChange = ExportChange
|
||||
{ oldTreeish :: [Git.Ref]
|
||||
, newTreeish :: Git.Ref
|
||||
}
|
||||
|
||||
parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported
|
||||
parseExportLog = parseMapLog exportParticipantsParser exportedParser
|
||||
|
||||
buildExportLog :: MapLog ExportParticipants Exported -> Builder
|
||||
buildExportLog = buildMapLog buildExportParticipants buildExported
|
||||
|
||||
buildExportParticipants :: ExportParticipants -> Builder
|
||||
buildExportParticipants ep =
|
||||
buildUUID (exportFrom ep) <> sep <> buildUUID (exportTo ep)
|
||||
where
|
||||
sep = charUtf8 ':'
|
||||
|
||||
exportParticipantsParser :: A.Parser ExportParticipants
|
||||
exportParticipantsParser = ExportParticipants
|
||||
<$> (toUUID <$> A8.takeWhile1 (/= ':'))
|
||||
<* A8.char ':'
|
||||
<*> (toUUID <$> A8.takeWhile1 (const True))
|
||||
|
||||
buildExported :: Exported -> Builder
|
||||
buildExported exported = go (exportedTreeish exported : incompleteExportedTreeish exported)
|
||||
where
|
||||
go [] = mempty
|
||||
go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]
|
||||
rref = byteString . Git.fromRef'
|
||||
|
||||
exportedParser :: A.Parser Exported
|
||||
exportedParser = Exported <$> refparser <*> many refparser
|
||||
where
|
||||
refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') )
|
||||
<* ((const () <$> A8.char ' ') <|> A.endOfInput)
|
||||
|
||||
-- Used when recording that an export is under way.
|
||||
-- Any LogEntry 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.
|
||||
updateForExportChange :: UUID -> ExportChange -> VectorClock -> UUID -> ExportParticipants -> LogEntry Exported -> LogEntry Exported
|
||||
updateForExportChange remoteuuid ec c hereuuid ep le@(LogEntry _ exported@(Exported { exportedTreeish = t }))
|
||||
| hereuuid == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le
|
||||
| otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec })
|
||||
|
|
@ -905,6 +905,7 @@ Executable git-annex
|
|||
Logs.Difference
|
||||
Logs.Difference.Pure
|
||||
Logs.Export
|
||||
Logs.Export.Pure
|
||||
Logs.File
|
||||
Logs.FsckResults
|
||||
Logs.Group
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue