Commit | Line | Data |
---|---|---|
7f9d184d | 1 | ;;; GNU Guix --- Functional package management for GNU |
a4678c6b | 2 | ;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org> |
7f9d184d CR |
3 | ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> |
4 | ;;; | |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix store database) | |
21 | #:use-module (sqlite3) | |
22 | #:use-module (guix config) | |
23 | #:use-module (guix serialization) | |
bf5bf577 | 24 | #:use-module (guix store deduplication) |
7f9d184d | 25 | #:use-module (guix base16) |
f0addd64 | 26 | #:use-module (guix progress) |
285cc75c | 27 | #:use-module (guix build syscalls) |
49c393cc LC |
28 | #:use-module ((guix build utils) |
29 | #:select (mkdir-p executable-file?)) | |
31a63be8 | 30 | #:use-module (guix build store-copy) |
3931c761 | 31 | #:use-module (srfi srfi-1) |
7f9d184d CR |
32 | #:use-module (srfi srfi-11) |
33 | #:use-module (srfi srfi-19) | |
f8f9f7ca | 34 | #:use-module (srfi srfi-26) |
3931c761 | 35 | #:use-module (rnrs io ports) |
7f9d184d | 36 | #:use-module (ice-9 match) |
3931c761 LC |
37 | #:use-module (system foreign) |
38 | #:export (sql-schema | |
1afe1985 | 39 | %default-database-file |
3931c761 | 40 | with-database |
1afe1985 | 41 | path-id |
3931c761 | 42 | sqlite-register |
285cc75c | 43 | register-path |
31a63be8 | 44 | register-items |
eb9fe974 | 45 | %epoch |
285cc75c | 46 | reset-timestamps)) |
7f9d184d CR |
47 | |
48 | ;;; Code for working with the store database directly. | |
49 | ||
3931c761 LC |
50 | (define sql-schema |
51 | ;; Name of the file containing the SQL scheme or #f. | |
52 | (make-parameter #f)) | |
7f9d184d | 53 | |
3931c761 LC |
54 | (define sqlite-exec |
55 | ;; XXX: This is was missing from guile-sqlite3 until | |
60e1c109 | 56 | ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. |
3931c761 LC |
57 | (let ((exec (pointer->procedure |
58 | int | |
59 | (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) | |
60 | '(* * * * *)))) | |
61 | (lambda (db text) | |
62 | (let ((ret (exec ((@@ (sqlite3) db-pointer) db) | |
63 | (string->pointer text) | |
64 | %null-pointer %null-pointer %null-pointer))) | |
65 | (unless (zero? ret) | |
66 | ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret)))))) | |
67 | ||
68 | (define (initialize-database db) | |
69 | "Initializing DB, an empty database, by creating all the tables and indexes | |
70 | as specified by SQL-SCHEMA." | |
71 | (define schema | |
72 | (or (sql-schema) | |
73 | (search-path %load-path "guix/store/schema.sql"))) | |
74 | ||
75 | (sqlite-exec db (call-with-input-file schema get-string-all))) | |
76 | ||
77 | (define (call-with-database file proc) | |
78 | "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, | |
79 | create it and initialize it as a new database." | |
80 | (let ((new? (not (file-exists? file))) | |
81 | (db (sqlite-open file))) | |
bdf860c2 LC |
82 | ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED |
83 | ;; errors when we have several readers: <https://www.sqlite.org/wal.html>. | |
84 | (sqlite-exec db "PRAGMA journal_mode=WAL;") | |
85 | ||
86 | ;; Install a busy handler such that, when the database is locked, sqlite | |
87 | ;; retries until 30 seconds have passed, at which point it gives up and | |
88 | ;; throws SQLITE_BUSY. | |
89 | (sqlite-exec db "PRAGMA busy_timeout = 30000;") | |
90 | ||
7f9d184d CR |
91 | (dynamic-wind noop |
92 | (lambda () | |
3931c761 LC |
93 | (when new? |
94 | (initialize-database db)) | |
95 | (proc db)) | |
7f9d184d CR |
96 | (lambda () |
97 | (sqlite-close db))))) | |
98 | ||
a4678c6b CR |
99 | ;; XXX: missing in guile-sqlite3@0.1.0 |
100 | (define SQLITE_BUSY 5) | |
101 | ||
102 | (define (call-with-transaction db proc) | |
103 | "Start a transaction with DB (make as many attempts as necessary) and run | |
104 | PROC. If PROC exits abnormally, abort the transaction, otherwise commit the | |
105 | transaction after it finishes." | |
106 | (catch 'sqlite-error | |
107 | (lambda () | |
108 | ;; We use begin immediate here so that if we need to retry, we | |
109 | ;; figure that out immediately rather than because some SQLITE_BUSY | |
110 | ;; exception gets thrown partway through PROC - in which case the | |
111 | ;; part already executed (which may contain side-effects!) would be | |
112 | ;; executed again for every retry. | |
113 | (sqlite-exec db "begin immediate;") | |
114 | (let ((result (proc))) | |
115 | (sqlite-exec db "commit;") | |
116 | result)) | |
117 | (lambda (key who error description) | |
118 | (if (= error SQLITE_BUSY) | |
119 | (call-with-transaction db proc) | |
120 | (begin | |
121 | (sqlite-exec db "rollback;") | |
122 | (throw 'sqlite-error who error description)))))) | |
123 | ||
1afe1985 LC |
124 | (define %default-database-file |
125 | ;; Default location of the store database. | |
126 | (string-append %store-database-directory "/db.sqlite")) | |
127 | ||
3931c761 LC |
128 | (define-syntax-rule (with-database file db exp ...) |
129 | "Open DB from FILE and close it when the dynamic extent of EXP... is left. | |
130 | If FILE doesn't exist, create it and initialize it as a new database." | |
131 | (call-with-database file (lambda (db) exp ...))) | |
132 | ||
7f9d184d CR |
133 | (define (last-insert-row-id db) |
134 | ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. | |
135 | ;; Work around that. | |
136 | (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" | |
33fddb76 | 137 | #:cache? #t)) |
7f9d184d CR |
138 | (result (sqlite-fold cons '() stmt))) |
139 | (sqlite-finalize stmt) | |
140 | (match result | |
141 | ((#(id)) id) | |
142 | (_ #f)))) | |
143 | ||
144 | (define path-id-sql | |
145 | "SELECT id FROM ValidPaths WHERE path = :path") | |
146 | ||
147 | (define* (path-id db path) | |
148 | "If PATH exists in the 'ValidPaths' table, return its numerical | |
149 | identifier. Otherwise, return #f." | |
150 | (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t))) | |
151 | (sqlite-bind-arguments stmt #:path path) | |
152 | (let ((result (sqlite-fold cons '() stmt))) | |
153 | (sqlite-finalize stmt) | |
154 | (match result | |
155 | ((#(id) . _) id) | |
156 | (_ #f))))) | |
157 | ||
158 | (define update-sql | |
159 | "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = | |
160 | :deriver, narSize = :size WHERE id = :id") | |
161 | ||
162 | (define insert-sql | |
163 | "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) | |
164 | VALUES (:path, :hash, :time, :deriver, :size)") | |
165 | ||
166 | (define* (update-or-insert db #:key path deriver hash nar-size time) | |
167 | "The classic update-if-exists and insert-if-doesn't feature that sqlite | |
168 | doesn't exactly have... they've got something close, but it involves deleting | |
169 | and re-inserting instead of updating, which causes problems with foreign keys, | |
170 | of course. Returns the row id of the row that was modified or inserted." | |
171 | (let ((id (path-id db path))) | |
172 | (if id | |
173 | (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) | |
174 | (sqlite-bind-arguments stmt #:id id | |
b85e2ff4 | 175 | #:deriver deriver |
7f9d184d CR |
176 | #:hash hash #:size nar-size #:time time) |
177 | (sqlite-fold cons '() stmt) | |
178 | (sqlite-finalize stmt) | |
179 | (last-insert-row-id db)) | |
180 | (let ((stmt (sqlite-prepare db insert-sql #:cache? #t))) | |
181 | (sqlite-bind-arguments stmt | |
182 | #:path path #:deriver deriver | |
183 | #:hash hash #:size nar-size #:time time) | |
184 | (sqlite-fold cons '() stmt) ;execute it | |
185 | (sqlite-finalize stmt) | |
186 | (last-insert-row-id db))))) | |
187 | ||
188 | (define add-reference-sql | |
122a6cad | 189 | "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") |
7f9d184d CR |
190 | |
191 | (define (add-references db referrer references) | |
192 | "REFERRER is the id of the referring store item, REFERENCES is a list | |
f8f9f7ca | 193 | ids of items referred to." |
7f9d184d CR |
194 | (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) |
195 | (for-each (lambda (reference) | |
196 | (sqlite-reset stmt) | |
197 | (sqlite-bind-arguments stmt #:referrer referrer | |
198 | #:reference reference) | |
199 | (sqlite-fold cons '() stmt) ;execute it | |
7f9d184d | 200 | (last-insert-row-id db)) |
a4678c6b CR |
201 | references) |
202 | (sqlite-finalize stmt))) | |
7f9d184d | 203 | |
ef1297e8 | 204 | (define* (sqlite-register db #:key path (references '()) |
eb9fe974 | 205 | deriver hash nar-size time) |
ef1297e8 LC |
206 | "Registers this stuff in DB. PATH is the store item to register and |
207 | REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' | |
208 | that produced PATH, HASH is the base16-encoded Nix sha256 hash of | |
209 | PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after | |
eb9fe974 LC |
210 | being converted to nar form. TIME is the registration time to be recorded in |
211 | the database or #f, meaning \"right now\". | |
f8f9f7ca LC |
212 | |
213 | Every store item in REFERENCES must already be registered." | |
ef1297e8 LC |
214 | (let ((id (update-or-insert db #:path path |
215 | #:deriver deriver | |
216 | #:hash hash | |
217 | #:nar-size nar-size | |
eb9fe974 LC |
218 | #:time (time-second |
219 | (or time | |
220 | (current-time time-utc)))))) | |
ef1297e8 LC |
221 | ;; Call 'path-id' on each of REFERENCES. This ensures we get a |
222 | ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. | |
223 | (add-references db id | |
224 | (map (cut path-id db <>) references)))) | |
7f9d184d CR |
225 | |
226 | \f | |
227 | ;;; | |
228 | ;;; High-level interface. | |
229 | ;;; | |
230 | ||
285cc75c LC |
231 | (define (reset-timestamps file) |
232 | "Reset the modification time on FILE and on all the files it contains, if | |
49c393cc | 233 | it's a directory. While at it, canonicalize file permissions." |
e4752118 LC |
234 | ;; Note: We're resetting to one second after the Epoch like 'guix-daemon' |
235 | ;; has always done. | |
285cc75c LC |
236 | (let loop ((file file) |
237 | (type (stat:type (lstat file)))) | |
238 | (case type | |
239 | ((directory) | |
49c393cc | 240 | (chmod file #o555) |
e4752118 | 241 | (utime file 1 1 0 0) |
285cc75c LC |
242 | (let ((parent file)) |
243 | (for-each (match-lambda | |
244 | (("." . _) #f) | |
245 | ((".." . _) #f) | |
246 | ((file . properties) | |
247 | (let ((file (string-append parent "/" file))) | |
248 | (loop file | |
249 | (match (assoc-ref properties 'type) | |
250 | ((or 'unknown #f) | |
251 | (stat:type (lstat file))) | |
252 | (type type)))))) | |
253 | (scandir* parent)))) | |
254 | ((symlink) | |
e4752118 | 255 | (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW)) |
285cc75c | 256 | (else |
49c393cc | 257 | (chmod file (if (executable-file? file) #o555 #o444)) |
e4752118 | 258 | (utime file 1 1 0 0))))) |
7f9d184d CR |
259 | |
260 | (define* (register-path path | |
261 | #:key (references '()) deriver prefix | |
33fddb76 | 262 | state-directory (deduplicate? #t) |
4bd86f0d | 263 | (reset-timestamps? #t) |
33fddb76 | 264 | (schema (sql-schema))) |
7f9d184d CR |
265 | "Register PATH as a valid store file, with REFERENCES as its list of |
266 | references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is | |
267 | given, it must be the name of the directory containing the new store to | |
268 | initialize; if STATE-DIRECTORY is given, it must be a string containing the | |
269 | absolute file name to the state directory of the store being initialized. | |
270 | Return #t on success. | |
271 | ||
272 | Use with care as it directly modifies the store! This is primarily meant to | |
273 | be used internally by the daemon's build hook." | |
31a63be8 LC |
274 | (register-items (list (store-info path deriver references)) |
275 | #:prefix prefix #:state-directory state-directory | |
276 | #:deduplicate? deduplicate? | |
277 | #:reset-timestamps? reset-timestamps? | |
f0addd64 LC |
278 | #:schema schema |
279 | #:log-port (%make-void-port "w"))) | |
31a63be8 | 280 | |
eb9fe974 LC |
281 | (define %epoch |
282 | ;; When it all began. | |
283 | (make-time time-utc 0 1)) | |
284 | ||
31a63be8 LC |
285 | (define* (register-items items |
286 | #:key prefix state-directory | |
287 | (deduplicate? #t) | |
288 | (reset-timestamps? #t) | |
eb9fe974 | 289 | registration-time |
f0addd64 LC |
290 | (schema (sql-schema)) |
291 | (log-port (current-error-port))) | |
31a63be8 LC |
292 | "Register all of ITEMS, a list of <store-info> records as returned by |
293 | 'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS | |
294 | must be in topological order (with leaves first.) If the database is | |
eb9fe974 | 295 | initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the |
f0addd64 LC |
296 | registration time to be recorded in the database; #f means \"now\". |
297 | Write a progress report to LOG-PORT." | |
bf5bf577 | 298 | |
31a63be8 LC |
299 | ;; Priority for options: first what is given, then environment variables, |
300 | ;; then defaults. %state-directory, %store-directory, and | |
301 | ;; %store-database-directory already handle the "environment variables / | |
302 | ;; defaults" question, so we only need to choose between what is given and | |
303 | ;; those. | |
304 | ||
305 | (define db-dir | |
306 | (cond (state-directory | |
307 | (string-append state-directory "/db")) | |
308 | (prefix | |
309 | (string-append prefix %localstatedir "/guix/db")) | |
310 | (else | |
311 | %store-database-directory))) | |
312 | ||
313 | (define store-dir | |
314 | (if prefix | |
315 | (string-append prefix %storedir) | |
316 | %store-directory)) | |
317 | ||
318 | (define (register db item) | |
319 | (define to-register | |
320 | (if prefix | |
321 | (string-append %storedir "/" (basename (store-info-item item))) | |
322 | ;; note: we assume here that if path is, for example, | |
323 | ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an | |
324 | ;; environment variable has been used to change the store directory | |
325 | ;; to /foo/bar/gnu/store, since otherwise real-path would end up | |
326 | ;; being /gnu/store/thing.txt, which is probably not the right file | |
327 | ;; in this case. | |
328 | (store-info-item item))) | |
329 | ||
330 | (define real-file-name | |
331 | (string-append store-dir "/" (basename (store-info-item item)))) | |
332 | ||
a4678c6b | 333 | |
bb3b6ccb LC |
334 | ;; When TO-REGISTER is already registered, skip it. This makes a |
335 | ;; significant differences when 'register-closures' is called | |
336 | ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. | |
337 | (unless (path-id db to-register) | |
31a63be8 LC |
338 | (when reset-timestamps? |
339 | (reset-timestamps real-file-name)) | |
bb3b6ccb LC |
340 | (let-values (((hash nar-size) (nar-sha256 real-file-name))) |
341 | (sqlite-register db #:path to-register | |
342 | #:references (store-info-references item) | |
343 | #:deriver (store-info-deriver item) | |
344 | #:hash (string-append "sha256:" | |
345 | (bytevector->base16-string hash)) | |
346 | #:nar-size nar-size | |
347 | #:time registration-time) | |
348 | (when deduplicate? | |
349 | (deduplicate real-file-name hash #:store store-dir))))) | |
31a63be8 LC |
350 | |
351 | (mkdir-p db-dir) | |
352 | (parameterize ((sql-schema schema)) | |
353 | (with-database (string-append db-dir "/db.sqlite") db | |
a4678c6b CR |
354 | (call-with-transaction db |
355 | (lambda () | |
356 | (let* ((prefix (format #f "registering ~a items" (length items))) | |
357 | (progress (progress-reporter/bar (length items) | |
358 | prefix log-port))) | |
359 | (call-with-progress-reporter progress | |
360 | (lambda (report) | |
361 | (for-each (lambda (item) | |
362 | (register db item) | |
363 | (report)) | |
364 | items))))))))) |