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.

Logs/Export.hs

@@ -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
+	hereuuid <- getUUID
-	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
+	let ep = ExportParticipants { exportFrom = hereuuid, exportTo = remoteuuid }
-	let exported = Exported (newTreeish ec) []
+	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

Logs/Export/Pure.hs

@@ -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 })

git-annex.cabal

@@ -905,6 +905,7 @@ Executable git-annex
     Logs.Difference
     Logs.Difference.Pure
     Logs.Export
+    Logs.Export.Pure
     Logs.File
     Logs.FsckResults
     Logs.Group