1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
{- git-annex export log
-
- Copyright 2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Logs.Export where
import qualified Data.Map as M
import Annex.Common
import qualified Annex.Branch
import qualified Git
import Git.Sha
import Git.FilePath
import Logs
import Logs.MapLog
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
data Exported = Exported
{ exportedTreeish :: Git.Ref
, incompleteExportedTreeish :: [Git.Ref]
}
deriving (Eq, Show)
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.
--
-- If the list contains multiple items, there was an export conflict,
-- and different trees were exported to the same special remote.
getExport :: UUID -> Annex [Exported]
getExport remoteuuid = nub . mapMaybe get . M.toList . simpleMap
. parseExportLog
<$> Annex.Branch.get exportLog
where
get (ep, exported)
| exportTo ep == remoteuuid = Just exported
| otherwise = Nothing
-- | Record a change in what's exported to a special remote.
--
-- 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.
--
-- Also, the newTreeish is grafted into the git-annex branch. This is done
-- to ensure that it's available later.
recordExport :: UUID -> ExportChange -> Annex ()
recordExport remoteuuid ec = do
c <- liftIO currentVectorClock
u <- getUUID
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
let exported = Exported (newTreeish ec) []
Annex.Branch.change exportLog $
buildExportLog
. changeMapLog c ep exported
. M.mapWithKey (updateothers c u)
. 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 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 <- liftIO currentVectorClock
u <- getUUID
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
old <- fromMaybe (Exported emptyTree [])
. M.lookup ep . simpleMap
. parseExportLog
<$> Annex.Branch.get exportLog
let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }
Annex.Branch.change exportLog $
buildExportLog
. changeMapLog c ep new
. parseExportLog
Annex.Branch.graftTreeish newtree (asTopFilePath "export.tree")
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 r = byteString (encodeBS' (Git.fromRef r))
exportedParser :: A.Parser Exported
exportedParser = Exported <$> refparser <*> many refparser
where
refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') )
<* ((const () <$> A8.char ' ') <|> A.endOfInput)
|
