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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
{- Sqlite database used for exports to special remotes.
-
- Copyright 2017 Joey Hess <id@joeyh.name>
- Copyright 2022 Benjamin Barenblat <bbarenblat@gmail.com>
-:
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes, DerivingStrategies, StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances, DataKinds, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module Database.Export (
ExportHandle,
openDb,
closeDb,
flushDbQueue,
addExportedLocation,
removeExportedLocation,
getExportedLocation,
isExportDirectoryEmpty,
getExportTreeCurrent,
recordExportTreeCurrent,
getExportTree,
addExportTree,
removeExportTree,
updateExportTree,
updateExportTree',
updateExportTreeFromLog,
ExportedId,
ExportedDirectoryId,
ExportTreeId,
ExportTreeCurrentId,
) where
import Database.Types
import qualified Database.Queue as H
import Database.Init
import Annex.Locations
import Annex.Common hiding (delete)
import Types.Export
import Annex.Export
import qualified Logs.Export as Log
import Annex.LockFile
import Git.Types
import Git.Sha
import Git.FilePath
import qualified Git.DiffTree
import Database.Persist.TH
import Database.Esqueleto hiding (Key)
data ExportHandle = ExportHandle H.DbQueue UUID
share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
-- Files that have been exported to the remote and are present on it.
Exported
key IKey
file SFilePath
ExportedIndex key file
-- Directories that exist on the remote, and the files that are in them.
ExportedDirectory
subdir SFilePath
file SFilePath
ExportedDirectoryIndex subdir file
-- The content of the tree that has been exported to the remote.
-- Not all of these files are necessarily present on the remote yet.
ExportTree
key IKey
file SFilePath
ExportTreeIndex key file
-- The tree stored in ExportTree
ExportTreeCurrent
tree SRef
UniqueTree tree
|]
{- Opens the database, creating it if it doesn't exist yet.
-
- Only a single process should write to the export at a time, so guard
- any writes with the gitAnnexExportLock.
-}
openDb :: UUID -> Annex ExportHandle
openDb u = do
dbdir <- fromRepo (gitAnnexExportDbDir u)
let db = dbdir </> "db"
unlessM (liftIO $ doesFileExist db) $ do
initDb db $ void $
runMigrationSilent migrateExport
h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"
return $ ExportHandle h u
closeDb :: ExportHandle -> Annex ()
closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h
queueDb :: ExportHandle -> SqlPersistM () -> IO ()
queueDb (ExportHandle h _) = H.queueDb h checkcommit
where
-- commit queue after 1000 changes
checkcommit sz _lastcommittime
| sz > 1000 = return True
| otherwise = return False
flushDbQueue :: ExportHandle -> IO ()
flushDbQueue (ExportHandle h _) = H.flushDbQueue h
recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()
recordExportTreeCurrent h s = queueDb h $ do
delete $ from $ \r -> do
where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)
void $ insertUnique $ ExportTreeCurrent $ toSRef s
getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)
getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
l <- select $ from $ \r -> do
where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)
return (r ^. ExportTreeCurrentTree)
case l of
(s:[]) -> return $ Just $ fromSRef $ unValue s
_ -> return Nothing
addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportedLocation h k el = queueDb h $ do
void $ insertUnique $ Exported ik ef
let edirs = map
(\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef)
(exportDirectories el)
#if MIN_VERSION_persistent(2,1,0)
insertMany_ edirs
#else
void $ insertMany edirs
#endif
where
ik = toIKey k
ef = toSFilePath (fromExportLocation el)
removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportedLocation h k el = queueDb h $ do
delete $ from $ \r -> do
where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)
let subdirs = map (toSFilePath . fromExportDirectory)
(exportDirectories el)
delete $ from $ \r -> do
where_ (r ^. ExportedDirectoryFile ==. val ef
&&. r ^. ExportedDirectorySubdir `in_` valList subdirs)
where
ik = toIKey k
ef = toSFilePath (fromExportLocation el)
{- Note that this does not see recently queued changes. -}
getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
l <- select $ from $ \r -> do
where_ (r ^. ExportedKey ==. val ik)
return (r ^. ExportedFile)
return $ map (mkExportLocation . fromSFilePath . unValue) l
where
ik = toIKey k
{- Note that this does not see recently queued changes. -}
isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do
l <- select $ from $ \r -> do
where_ (r ^. ExportedDirectorySubdir ==. val ed)
return (r ^. ExportedDirectoryFile)
return $ null l
where
ed = toSFilePath $ fromExportDirectory d
{- Get locations in the export that might contain a key. -}
getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
l <- select $ from $ \r -> do
where_ (r ^. ExportTreeKey ==. val ik)
return (r ^. ExportTreeFile)
return $ map (mkExportLocation . fromSFilePath . unValue) l
where
ik = toIKey k
addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportTree h k loc = queueDb h $
void $ insertUnique $ ExportTree ik ef
where
ik = toIKey k
ef = toSFilePath (fromExportLocation loc)
removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportTree h k loc = queueDb h $
delete $ from $ \r ->
where_ (r ^. ExportTreeKey ==. val ik &&. r ^. ExportTreeFile ==. val ef)
where
ik = toIKey k
ef = toSFilePath (fromExportLocation loc)
{- Diff from the old to the new tree and update the ExportTree table. -}
updateExportTree :: ExportHandle -> Sha -> Sha -> Annex ()
updateExportTree h old new = do
(diff, cleanup) <- inRepo $
Git.DiffTree.diffTreeRecursive old new
forM_ diff $ \i -> do
srcek <- getek (Git.DiffTree.srcsha i)
dstek <- getek (Git.DiffTree.dstsha i)
updateExportTree' h srcek dstek i
void $ liftIO cleanup
where
getek sha
| sha == nullSha = return Nothing
| otherwise = Just <$> exportKey sha
updateExportTree' :: ExportHandle -> Maybe ExportKey -> Maybe ExportKey -> Git.DiffTree.DiffTreeItem-> Annex ()
updateExportTree' h srcek dstek i = do
case srcek of
Nothing -> return ()
Just k -> liftIO $ removeExportTree h (asKey k) loc
case dstek of
Nothing -> return ()
Just k -> liftIO $ addExportTree h (asKey k) loc
where
loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i
updateExportTreeFromLog :: ExportHandle -> Annex ()
updateExportTreeFromLog db@(ExportHandle _ u) =
withExclusiveLock (gitAnnexExportLock u) $ do
old <- liftIO $ fromMaybe emptyTree
<$> getExportTreeCurrent db
l <- Log.getExport u
case map Log.exportedTreeish l of
(new:[]) | new /= old -> do
updateExportTree db old new
liftIO $ recordExportTreeCurrent db new
liftIO $ flushDbQueue db
_ -> return ()
|
