Pure.hs

{- 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,
	parseExportLogMap,
	buildExportLog,
	updateForExportChange,
) where

import Annex.Common
import Annex.VectorClock
import qualified Git
import Logs.MapLog

import qualified Data.Map as M
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 constructor 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

parseExportLogMap :: L.ByteString -> M.Map ExportParticipants Exported
parseExportLogMap = simpleMap . parseExportLog

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 -> CandidateVectorClock -> UUID -> ExportParticipants -> LogEntry Exported -> LogEntry Exported
updateForExportChange remoteuuid ec c hereuuid ep le@(LogEntry lc exported@(Exported { exportedTreeish = t }))
	| hereuuid == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le
	| otherwise = LogEntry c' (exported { exportedTreeish = newTreeish ec })
  where
	c' = advanceVectorClock c [lc]