Commit | Line | Data |
---|---|---|
7f9d184d | 1 | ;;; GNU Guix --- Functional package management for GNU |
a4678c6b | 2 | ;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org> |
7fa6155b | 3 | ;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org> |
4b9eecd3 | 4 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
7f9d184d CR |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix store database) | |
22 | #:use-module (sqlite3) | |
23 | #:use-module (guix config) | |
24 | #:use-module (guix serialization) | |
bf5bf577 | 25 | #:use-module (guix store deduplication) |
7f9d184d | 26 | #:use-module (guix base16) |
f0addd64 | 27 | #:use-module (guix progress) |
285cc75c | 28 | #:use-module (guix build syscalls) |
49c393cc LC |
29 | #:use-module ((guix build utils) |
30 | #:select (mkdir-p executable-file?)) | |
31a63be8 | 31 | #:use-module (guix build store-copy) |
3931c761 | 32 | #:use-module (srfi srfi-1) |
7f9d184d CR |
33 | #:use-module (srfi srfi-11) |
34 | #:use-module (srfi srfi-19) | |
f8f9f7ca | 35 | #:use-module (srfi srfi-26) |
3931c761 | 36 | #:use-module (rnrs io ports) |
7f9d184d | 37 | #:use-module (ice-9 match) |
3931c761 LC |
38 | #:use-module (system foreign) |
39 | #:export (sql-schema | |
1afe1985 | 40 | %default-database-file |
97a46055 | 41 | store-database-file |
3931c761 | 42 | with-database |
1afe1985 | 43 | path-id |
3931c761 | 44 | sqlite-register |
285cc75c | 45 | register-path |
31a63be8 | 46 | register-items |
eb9fe974 | 47 | %epoch |
285cc75c | 48 | reset-timestamps)) |
7f9d184d CR |
49 | |
50 | ;;; Code for working with the store database directly. | |
51 | ||
3931c761 LC |
52 | (define sql-schema |
53 | ;; Name of the file containing the SQL scheme or #f. | |
54 | (make-parameter #f)) | |
7f9d184d | 55 | |
3931c761 LC |
56 | (define sqlite-exec |
57 | ;; XXX: This is was missing from guile-sqlite3 until | |
60e1c109 | 58 | ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. |
3931c761 LC |
59 | (let ((exec (pointer->procedure |
60 | int | |
61 | (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) | |
62 | '(* * * * *)))) | |
63 | (lambda (db text) | |
64 | (let ((ret (exec ((@@ (sqlite3) db-pointer) db) | |
65 | (string->pointer text) | |
66 | %null-pointer %null-pointer %null-pointer))) | |
67 | (unless (zero? ret) | |
68 | ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret)))))) | |
69 | ||
97a46055 LC |
70 | (define* (store-database-directory #:key prefix state-directory) |
71 | "Return the store database directory, taking PREFIX and STATE-DIRECTORY into | |
72 | account when provided." | |
73 | ;; Priority for options: first what is given, then environment variables, | |
74 | ;; then defaults. %state-directory, %store-directory, and | |
75 | ;; %store-database-directory already handle the "environment variables / | |
76 | ;; defaults" question, so we only need to choose between what is given and | |
77 | ;; those. | |
78 | (cond (state-directory | |
79 | (string-append state-directory "/db")) | |
80 | (prefix | |
81 | (string-append prefix %localstatedir "/guix/db")) | |
82 | (else | |
83 | %store-database-directory))) | |
84 | ||
85 | (define* (store-database-file #:key prefix state-directory) | |
86 | "Return the store database file name, taking PREFIX and STATE-DIRECTORY into | |
87 | account when provided." | |
88 | (string-append (store-database-directory #:prefix prefix | |
89 | #:state-directory state-directory) | |
90 | "/db.sqlite")) | |
91 | ||
3931c761 LC |
92 | (define (initialize-database db) |
93 | "Initializing DB, an empty database, by creating all the tables and indexes | |
94 | as specified by SQL-SCHEMA." | |
95 | (define schema | |
96 | (or (sql-schema) | |
97 | (search-path %load-path "guix/store/schema.sql"))) | |
98 | ||
99 | (sqlite-exec db (call-with-input-file schema get-string-all))) | |
100 | ||
4b9eecd3 | 101 | (define* (call-with-database file proc #:key (wal-mode? #t)) |
3931c761 | 102 | "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, |
4b9eecd3 JN |
103 | create it and initialize it as a new database. Unless WAL-MODE? is set to #f, |
104 | set journal_mode=WAL." | |
97a46055 LC |
105 | (let ((new? (and (not (file-exists? file)) |
106 | (begin | |
107 | (mkdir-p (dirname file)) | |
108 | #t))) | |
3931c761 | 109 | (db (sqlite-open file))) |
4b9eecd3 JN |
110 | ;; Using WAL breaks for the Hurd <https://bugs.gnu.org/42151>. |
111 | (when wal-mode? | |
112 | ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED | |
113 | ;; errors when we have several readers: <https://www.sqlite.org/wal.html>. | |
114 | (sqlite-exec db "PRAGMA journal_mode=WAL;")) | |
bdf860c2 LC |
115 | |
116 | ;; Install a busy handler such that, when the database is locked, sqlite | |
117 | ;; retries until 30 seconds have passed, at which point it gives up and | |
118 | ;; throws SQLITE_BUSY. | |
119 | (sqlite-exec db "PRAGMA busy_timeout = 30000;") | |
120 | ||
7f9d184d CR |
121 | (dynamic-wind noop |
122 | (lambda () | |
3931c761 LC |
123 | (when new? |
124 | (initialize-database db)) | |
125 | (proc db)) | |
7f9d184d CR |
126 | (lambda () |
127 | (sqlite-close db))))) | |
128 | ||
a4678c6b CR |
129 | ;; XXX: missing in guile-sqlite3@0.1.0 |
130 | (define SQLITE_BUSY 5) | |
131 | ||
8971f626 CR |
132 | (define (call-with-SQLITE_BUSY-retrying thunk) |
133 | "Call THUNK, retrying as long as it exits abnormally due to SQLITE_BUSY | |
134 | errors." | |
a4678c6b | 135 | (catch 'sqlite-error |
8971f626 CR |
136 | thunk |
137 | (lambda (key who code errmsg) | |
138 | (if (= code SQLITE_BUSY) | |
139 | (call-with-SQLITE_BUSY-retrying thunk) | |
140 | (throw key who code errmsg))))) | |
141 | ||
142 | ||
143 | ||
144 | (define* (call-with-transaction db proc #:key restartable?) | |
145 | "Start a transaction with DB and run PROC. If PROC exits abnormally, abort | |
146 | the transaction, otherwise commit the transaction after it finishes. | |
147 | RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple | |
148 | times. This may reduce contention for the database somewhat." | |
149 | (define (exec sql) | |
150 | (with-statement db sql stmt | |
151 | (sqlite-fold cons '() stmt))) | |
152 | ;; We might use begin immediate here so that if we need to retry, we figure | |
153 | ;; that out immediately rather than because some SQLITE_BUSY exception gets | |
154 | ;; thrown partway through PROC - in which case the part already executed | |
155 | ;; (which may contain side-effects!) might have to be executed again for | |
156 | ;; every retry. | |
157 | (exec (if restartable? "begin;" "begin immediate;")) | |
158 | (catch #t | |
a4678c6b | 159 | (lambda () |
8971f626 CR |
160 | (let-values ((result (proc))) |
161 | (exec "commit;") | |
162 | (apply values result))) | |
163 | (lambda args | |
164 | ;; The roll back may or may not have occurred automatically when the | |
165 | ;; error was generated. If it has occurred, this does nothing but signal | |
166 | ;; an error. If it hasn't occurred, this needs to be done. | |
167 | (false-if-exception (exec "rollback;")) | |
168 | (apply throw args)))) | |
169 | ||
37545de4 CR |
170 | (define* (call-with-savepoint db proc |
171 | #:optional (savepoint-name "SomeSavepoint")) | |
172 | "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits | |
173 | abnormally, rollback to that savepoint. In all cases, remove the savepoint | |
174 | prior to returning." | |
175 | (define (exec sql) | |
176 | (with-statement db sql stmt | |
177 | (sqlite-fold cons '() stmt))) | |
178 | ||
179 | (dynamic-wind | |
180 | (lambda () | |
181 | (exec (string-append "SAVEPOINT " savepoint-name ";"))) | |
182 | (lambda () | |
183 | (catch #t | |
184 | proc | |
185 | (lambda args | |
186 | (exec (string-append "ROLLBACK TO " savepoint-name ";")) | |
187 | (apply throw args)))) | |
188 | (lambda () | |
189 | (exec (string-append "RELEASE " savepoint-name ";"))))) | |
a4678c6b | 190 | |
8971f626 CR |
191 | (define* (call-with-retrying-transaction db proc #:key restartable?) |
192 | (call-with-SQLITE_BUSY-retrying | |
193 | (lambda () | |
194 | (call-with-transaction db proc #:restartable? restartable?)))) | |
195 | ||
196 | (define* (call-with-retrying-savepoint db proc | |
197 | #:optional (savepoint-name | |
198 | "SomeSavepoint")) | |
199 | (call-with-SQLITE_BUSY-retrying | |
200 | (lambda () | |
201 | (call-with-savepoint db proc savepoint-name)))) | |
202 | ||
1afe1985 LC |
203 | (define %default-database-file |
204 | ;; Default location of the store database. | |
205 | (string-append %store-database-directory "/db.sqlite")) | |
206 | ||
4b9eecd3 JN |
207 | (define-syntax with-database |
208 | (syntax-rules () | |
209 | "Open DB from FILE and close it when the dynamic extent of EXP... is left. | |
210 | If FILE doesn't exist, create it and initialize it as a new database. Pass | |
211 | #:wal-mode? to call-with-database." | |
212 | ((_ file db #:wal-mode? wal-mode? exp ...) | |
213 | (call-with-database file (lambda (db) exp ...) #:wal-mode? wal-mode?)) | |
214 | ((_ file db exp ...) | |
215 | (call-with-database file (lambda (db) exp ...))))) | |
3931c761 | 216 | |
3cd92a85 CR |
217 | (define (sqlite-finalize stmt) |
218 | ;; As of guile-sqlite3 0.1.0, cached statements aren't reset when | |
219 | ;; sqlite-finalize is invoked on them (see | |
220 | ;; https://notabug.org/guile-sqlite3/guile-sqlite3/issues/12). This can | |
221 | ;; cause problems with automatically-started transactions, so we work around | |
222 | ;; it by wrapping sqlite-finalize so that sqlite-reset is always called. | |
223 | ;; This always works, because resetting a statement twice has no adverse | |
224 | ;; effects. We can remove this once the fixed guile-sqlite3 is widespread. | |
225 | (sqlite-reset stmt) | |
226 | ((@ (sqlite3) sqlite-finalize) stmt)) | |
227 | ||
5d6e2255 CR |
228 | (define (call-with-statement db sql proc) |
229 | (let ((stmt (sqlite-prepare db sql #:cache? #t))) | |
230 | (dynamic-wind | |
231 | (const #t) | |
232 | (lambda () | |
233 | (proc stmt)) | |
234 | (lambda () | |
235 | (sqlite-finalize stmt))))) | |
236 | ||
237 | (define-syntax-rule (with-statement db sql stmt exp ...) | |
238 | "Run EXP... with STMT bound to a prepared statement corresponding to the sql | |
239 | string SQL for DB." | |
240 | (call-with-statement db sql | |
241 | (lambda (stmt) exp ...))) | |
242 | ||
7f9d184d CR |
243 | (define (last-insert-row-id db) |
244 | ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. | |
245 | ;; Work around that. | |
5d6e2255 CR |
246 | (with-statement db "SELECT last_insert_rowid();" stmt |
247 | (match (sqlite-fold cons '() stmt) | |
7f9d184d CR |
248 | ((#(id)) id) |
249 | (_ #f)))) | |
250 | ||
251 | (define path-id-sql | |
252 | "SELECT id FROM ValidPaths WHERE path = :path") | |
253 | ||
254 | (define* (path-id db path) | |
255 | "If PATH exists in the 'ValidPaths' table, return its numerical | |
256 | identifier. Otherwise, return #f." | |
5d6e2255 | 257 | (with-statement db path-id-sql stmt |
7f9d184d | 258 | (sqlite-bind-arguments stmt #:path path) |
5d6e2255 CR |
259 | (match (sqlite-fold cons '() stmt) |
260 | ((#(id) . _) id) | |
261 | (_ #f)))) | |
7f9d184d CR |
262 | |
263 | (define update-sql | |
264 | "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = | |
265 | :deriver, narSize = :size WHERE id = :id") | |
266 | ||
267 | (define insert-sql | |
268 | "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) | |
269 | VALUES (:path, :hash, :time, :deriver, :size)") | |
270 | ||
271 | (define* (update-or-insert db #:key path deriver hash nar-size time) | |
272 | "The classic update-if-exists and insert-if-doesn't feature that sqlite | |
273 | doesn't exactly have... they've got something close, but it involves deleting | |
274 | and re-inserting instead of updating, which causes problems with foreign keys, | |
275 | of course. Returns the row id of the row that was modified or inserted." | |
37545de4 CR |
276 | |
277 | ;; It's important that querying the path-id and the insert/update operation | |
278 | ;; take place in the same transaction, as otherwise some other | |
279 | ;; process/thread/fiber could register the same path between when we check | |
280 | ;; whether it's already registered and when we register it, resulting in | |
281 | ;; duplicate paths (which, due to a 'unique' constraint, would cause an | |
282 | ;; exception to be thrown). With the default journaling mode this will | |
283 | ;; prevent writes from occurring during that sensitive time, but with WAL | |
284 | ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs | |
285 | ;; between the start of a read transaction and its upgrading to a write | |
286 | ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot). | |
287 | ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and | |
288 | ;; immediately return (makes sense, since waiting won't change anything). | |
289 | ||
290 | ;; Note that when that kind of SQLITE_BUSY error is returned, it will keep | |
291 | ;; being returned every time we try to upgrade the same outermost | |
292 | ;; transaction to a write transaction. So when retrying, we have to restart | |
293 | ;; the *outermost* write transaction. We can't inherently tell whether | |
294 | ;; we're the outermost write transaction, so we leave the retry-handling to | |
295 | ;; the caller. | |
296 | (call-with-savepoint db | |
297 | (lambda () | |
298 | (let ((id (path-id db path))) | |
299 | (if id | |
300 | (with-statement db update-sql stmt | |
301 | (sqlite-bind-arguments stmt #:id id | |
302 | #:deriver deriver | |
303 | #:hash hash #:size nar-size #:time time) | |
304 | (sqlite-fold cons '() stmt)) | |
305 | (with-statement db insert-sql stmt | |
306 | (sqlite-bind-arguments stmt | |
307 | #:path path #:deriver deriver | |
308 | #:hash hash #:size nar-size #:time time) | |
309 | (sqlite-fold cons '() stmt))) | |
310 | (last-insert-row-id db))))) | |
7f9d184d CR |
311 | |
312 | (define add-reference-sql | |
122a6cad | 313 | "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") |
7f9d184d CR |
314 | |
315 | (define (add-references db referrer references) | |
316 | "REFERRER is the id of the referring store item, REFERENCES is a list | |
f8f9f7ca | 317 | ids of items referred to." |
5d6e2255 | 318 | (with-statement db add-reference-sql stmt |
7f9d184d CR |
319 | (for-each (lambda (reference) |
320 | (sqlite-reset stmt) | |
321 | (sqlite-bind-arguments stmt #:referrer referrer | |
322 | #:reference reference) | |
5d6e2255 CR |
323 | (sqlite-fold cons '() stmt)) |
324 | references))) | |
7f9d184d | 325 | |
ef1297e8 | 326 | (define* (sqlite-register db #:key path (references '()) |
eb9fe974 | 327 | deriver hash nar-size time) |
ef1297e8 LC |
328 | "Registers this stuff in DB. PATH is the store item to register and |
329 | REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' | |
330 | that produced PATH, HASH is the base16-encoded Nix sha256 hash of | |
331 | PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after | |
eb9fe974 LC |
332 | being converted to nar form. TIME is the registration time to be recorded in |
333 | the database or #f, meaning \"right now\". | |
f8f9f7ca LC |
334 | |
335 | Every store item in REFERENCES must already be registered." | |
ef1297e8 LC |
336 | (let ((id (update-or-insert db #:path path |
337 | #:deriver deriver | |
338 | #:hash hash | |
339 | #:nar-size nar-size | |
eb9fe974 LC |
340 | #:time (time-second |
341 | (or time | |
342 | (current-time time-utc)))))) | |
ef1297e8 LC |
343 | ;; Call 'path-id' on each of REFERENCES. This ensures we get a |
344 | ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. | |
345 | (add-references db id | |
346 | (map (cut path-id db <>) references)))) | |
7f9d184d CR |
347 | |
348 | \f | |
349 | ;;; | |
350 | ;;; High-level interface. | |
351 | ;;; | |
352 | ||
7fa6155b | 353 | (define* (reset-timestamps file #:key preserve-permissions?) |
285cc75c | 354 | "Reset the modification time on FILE and on all the files it contains, if |
7fa6155b LC |
355 | it's a directory. Canonicalize file permissions unless PRESERVE-PERMISSIONS? |
356 | is true." | |
e4752118 LC |
357 | ;; Note: We're resetting to one second after the Epoch like 'guix-daemon' |
358 | ;; has always done. | |
285cc75c LC |
359 | (let loop ((file file) |
360 | (type (stat:type (lstat file)))) | |
361 | (case type | |
362 | ((directory) | |
7fa6155b LC |
363 | (unless preserve-permissions? |
364 | (chmod file #o555)) | |
e4752118 | 365 | (utime file 1 1 0 0) |
285cc75c LC |
366 | (let ((parent file)) |
367 | (for-each (match-lambda | |
368 | (("." . _) #f) | |
369 | ((".." . _) #f) | |
370 | ((file . properties) | |
371 | (let ((file (string-append parent "/" file))) | |
372 | (loop file | |
373 | (match (assoc-ref properties 'type) | |
374 | ((or 'unknown #f) | |
375 | (stat:type (lstat file))) | |
376 | (type type)))))) | |
377 | (scandir* parent)))) | |
378 | ((symlink) | |
e4752118 | 379 | (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW)) |
285cc75c | 380 | (else |
7fa6155b LC |
381 | (unless preserve-permissions? |
382 | (chmod file (if (executable-file? file) #o555 #o444))) | |
e4752118 | 383 | (utime file 1 1 0 0))))) |
7f9d184d CR |
384 | |
385 | (define* (register-path path | |
386 | #:key (references '()) deriver prefix | |
33fddb76 | 387 | state-directory (deduplicate? #t) |
4bd86f0d | 388 | (reset-timestamps? #t) |
33fddb76 | 389 | (schema (sql-schema))) |
7f9d184d CR |
390 | "Register PATH as a valid store file, with REFERENCES as its list of |
391 | references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is | |
392 | given, it must be the name of the directory containing the new store to | |
393 | initialize; if STATE-DIRECTORY is given, it must be a string containing the | |
394 | absolute file name to the state directory of the store being initialized. | |
dea1ee1f LC |
395 | Return #t on success. As a side effect, reset timestamps on PATH, unless |
396 | RESET-TIMESTAMPS? is false. | |
7f9d184d CR |
397 | |
398 | Use with care as it directly modifies the store! This is primarily meant to | |
a05c31ab CR |
399 | be used internally by the daemon's build hook. |
400 | ||
401 | PATH must be protected from GC and locked during execution of this, typically | |
402 | by adding it as a temp-root." | |
97a46055 LC |
403 | (define db-file |
404 | (store-database-file #:prefix prefix | |
405 | #:state-directory state-directory)) | |
406 | ||
dea1ee1f LC |
407 | (define real-file-name |
408 | (string-append (or prefix "") path)) | |
409 | ||
0793833c LC |
410 | (when deduplicate? |
411 | (deduplicate real-file-name (nar-sha256 real-file-name) | |
412 | #:store (string-append (or prefix "") | |
413 | %store-directory))) | |
414 | ||
dea1ee1f LC |
415 | (when reset-timestamps? |
416 | (reset-timestamps real-file-name)) | |
417 | ||
97a46055 LC |
418 | (parameterize ((sql-schema schema)) |
419 | (with-database db-file db | |
420 | (register-items db (list (store-info path deriver references)) | |
421 | #:prefix prefix | |
97a46055 | 422 | #:log-port (%make-void-port "w"))))) |
31a63be8 | 423 | |
eb9fe974 LC |
424 | (define %epoch |
425 | ;; When it all began. | |
426 | (make-time time-utc 0 1)) | |
427 | ||
97a46055 LC |
428 | (define* (register-items db items |
429 | #:key prefix | |
eb9fe974 | 430 | registration-time |
f0addd64 | 431 | (log-port (current-error-port))) |
31a63be8 | 432 | "Register all of ITEMS, a list of <store-info> records as returned by |
97a46055 LC |
433 | 'read-reference-graph', in DB. ITEMS must be in topological order (with |
434 | leaves first.) REGISTRATION-TIME must be the registration time to be recorded | |
a05c31ab CR |
435 | in the database; #f means \"now\". Write a progress report to LOG-PORT. All |
436 | of ITEMS must be protected from GC and locked during execution of this, | |
437 | typically by adding them as temp-roots." | |
31a63be8 LC |
438 | (define store-dir |
439 | (if prefix | |
440 | (string-append prefix %storedir) | |
441 | %store-directory)) | |
442 | ||
443 | (define (register db item) | |
444 | (define to-register | |
445 | (if prefix | |
446 | (string-append %storedir "/" (basename (store-info-item item))) | |
447 | ;; note: we assume here that if path is, for example, | |
448 | ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an | |
449 | ;; environment variable has been used to change the store directory | |
450 | ;; to /foo/bar/gnu/store, since otherwise real-path would end up | |
451 | ;; being /gnu/store/thing.txt, which is probably not the right file | |
452 | ;; in this case. | |
453 | (store-info-item item))) | |
454 | ||
455 | (define real-file-name | |
456 | (string-append store-dir "/" (basename (store-info-item item)))) | |
457 | ||
a4678c6b | 458 | |
bb3b6ccb LC |
459 | ;; When TO-REGISTER is already registered, skip it. This makes a |
460 | ;; significant differences when 'register-closures' is called | |
461 | ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. | |
462 | (unless (path-id db to-register) | |
bb3b6ccb | 463 | (let-values (((hash nar-size) (nar-sha256 real-file-name))) |
2932591b CB |
464 | (call-with-retrying-transaction db |
465 | (lambda () | |
466 | (sqlite-register db #:path to-register | |
467 | #:references (store-info-references item) | |
468 | #:deriver (store-info-deriver item) | |
469 | #:hash (string-append | |
470 | "sha256:" | |
471 | (bytevector->base16-string hash)) | |
472 | #:nar-size nar-size | |
0793833c | 473 | #:time registration-time)))))) |
31a63be8 | 474 | |
2932591b CB |
475 | (let* ((prefix (format #f "registering ~a items" (length items))) |
476 | (progress (progress-reporter/bar (length items) | |
477 | prefix log-port))) | |
478 | (call-with-progress-reporter progress | |
479 | (lambda (report) | |
480 | (for-each (lambda (item) | |
481 | (register db item) | |
482 | (report)) | |
483 | items))))) |