diff options
Diffstat (limited to 'guix/store/database.scm')
| -rw-r--r-- | guix/store/database.scm | 235 |
1 files changed, 153 insertions, 82 deletions
diff --git a/guix/store/database.scm b/guix/store/database.scm index 3623c0e7a0..05b2ba6c3f 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -24,30 +24,76 @@ #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix build syscalls) + #:use-module ((guix build utils) + #:select (mkdir-p executable-file?)) + #:use-module (guix build store-copy) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) #:use-module (ice-9 match) - #:export (sqlite-register + #:use-module (system foreign) + #:export (sql-schema + with-database + sqlite-register register-path + register-items + %epoch reset-timestamps)) ;;; Code for working with the store database directly. +(define sql-schema + ;; Name of the file containing the SQL scheme or #f. + (make-parameter #f)) -(define-syntax-rule (with-database file db exp ...) - "Open DB from FILE and close it when the dynamic extent of EXP... is left." - (let ((db (sqlite-open file))) +(define sqlite-exec + ;; XXX: This is was missing from guile-sqlite3 until + ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. + (let ((exec (pointer->procedure + int + (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) + '(* * * * *)))) + (lambda (db text) + (let ((ret (exec ((@@ (sqlite3) db-pointer) db) + (string->pointer text) + %null-pointer %null-pointer %null-pointer))) + (unless (zero? ret) + ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret)))))) + +(define (initialize-database db) + "Initializing DB, an empty database, by creating all the tables and indexes +as specified by SQL-SCHEMA." + (define schema + (or (sql-schema) + (search-path %load-path "guix/store/schema.sql"))) + + (sqlite-exec db (call-with-input-file schema get-string-all))) + +(define (call-with-database file proc) + "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, +create it and initialize it as a new database." + (let ((new? (not (file-exists? file))) + (db (sqlite-open file))) (dynamic-wind noop (lambda () - exp ...) + (when new? + (initialize-database db)) + (proc db)) (lambda () (sqlite-close db))))) +(define-syntax-rule (with-database file db exp ...) + "Open DB from FILE and close it when the dynamic extent of EXP... is left. +If FILE doesn't exist, create it and initialize it as a new database." + (call-with-database file (lambda (db) exp ...))) + (define (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" - #:cache? #t)) + #:cache? #t)) (result (sqlite-fold cons '() stmt))) (sqlite-finalize stmt) (match result @@ -85,7 +131,7 @@ of course. Returns the row id of the row that was modified or inserted." (if id (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) (sqlite-bind-arguments stmt #:id id - #:path path #:deriver deriver + #:deriver deriver #:hash hash #:size nar-size #:time time) (sqlite-fold cons '() stmt) (sqlite-finalize stmt) @@ -99,13 +145,11 @@ of course. Returns the row id of the row that was modified or inserted." (last-insert-row-id db))))) (define add-reference-sql - "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id -FROM ValidPaths WHERE path = :reference") + "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list -containing store items being referred to. Note that all of the store items in -REFERENCES must already be registered." +ids of items referred to." (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) (for-each (lambda (reference) (sqlite-reset stmt) @@ -116,37 +160,41 @@ REFERENCES must already be registered." (last-insert-row-id db)) references))) -;; XXX figure out caching of statement and database objects... later -(define* (sqlite-register #:key db-file path (references '()) - deriver hash nar-size) - "Registers this stuff in a database specified by DB-FILE. PATH is the string -path of some store item, REFERENCES is a list of string paths which the store -item PATH refers to (they need to be already registered!), DERIVER is a string -path of the derivation that created the store item PATH, HASH is the -base16-encoded sha256 hash of the store item denoted by PATH (prefixed with -\"sha256:\") after being converted to nar form, and nar-size is the size in -bytes of the store item denoted by PATH after being converted to nar form." - (with-database db-file db - (let ((id (update-or-insert db #:path path - #:deriver deriver - #:hash hash - #:nar-size nar-size - #:time (time-second (current-time time-utc))))) - (add-references db id references)))) +(define* (sqlite-register db #:key path (references '()) + deriver hash nar-size time) + "Registers this stuff in DB. PATH is the store item to register and +REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' +that produced PATH, HASH is the base16-encoded Nix sha256 hash of +PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after +being converted to nar form. TIME is the registration time to be recorded in +the database or #f, meaning \"right now\". + +Every store item in REFERENCES must already be registered." + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second + (or time + (current-time time-utc)))))) + ;; Call 'path-id' on each of REFERENCES. This ensures we get a + ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. + (add-references db id + (map (cut path-id db <>) references)))) ;;; ;;; High-level interface. ;;; -;; TODO: Factorize with that in (gnu build install). (define (reset-timestamps file) "Reset the modification time on FILE and on all the files it contains, if -it's a directory." +it's a directory. While at it, canonicalize file permissions." (let loop ((file file) (type (stat:type (lstat file)))) (case type ((directory) + (chmod file #o555) (utime file 0 0 0 0) (let ((parent file)) (for-each (match-lambda @@ -165,24 +213,14 @@ it's a directory." ;; symlinks. #f) (else + (chmod file (if (executable-file? file) #o555 #o444)) (utime file 0 0 0 0))))) -;; TODO: make this canonicalize store items that are registered. This involves -;; setting permissions and timestamps, I think. Also, run a "deduplication -;; pass", whatever that involves. Also, handle databases not existing yet -;; (what should the default behavior be? Figuring out how the C++ stuff -;; currently does it sounds like a lot of grepping for global -;; variables...). Also, return #t on success like the documentation says we -;; should. - (define* (register-path path #:key (references '()) deriver prefix - state-directory (deduplicate? #t)) - ;; Priority for options: first what is given, then environment variables, - ;; then defaults. %state-directory, %store-directory, and - ;; %store-database-directory already handle the "environment variables / - ;; defaults" question, so we only need to choose between what is given and - ;; those. + state-directory (deduplicate? #t) + (reset-timestamps? #t) + (schema (sql-schema))) "Register PATH as a valid store file, with REFERENCES as its list of references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is given, it must be the name of the directory containing the new store to @@ -192,43 +230,76 @@ Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook." - (let* ((db-dir (cond - (state-directory - (string-append state-directory "/db")) - (prefix - ;; If prefix is specified, the value of NIX_STATE_DIR - ;; (which affects %state-directory) isn't supposed to - ;; affect db-dir, only the compile-time-customized - ;; default should. - (string-append prefix %localstatedir "/guix/db")) - (else - %store-database-directory))) - (store-dir (if prefix - ;; same situation as above - (string-append prefix %storedir) - %store-directory)) - (to-register (if prefix - (string-append %storedir "/" (basename path)) - ;; note: we assume here that if path is, for - ;; example, /foo/bar/gnu/store/thing.txt and prefix - ;; isn't given, then an environment variable has - ;; been used to change the store directory to - ;; /foo/bar/gnu/store, since otherwise real-path - ;; would end up being /gnu/store/thing.txt, which is - ;; probably not the right file in this case. - path)) - (real-path (string-append store-dir "/" (basename path)))) - (let-values (((hash nar-size) - (nar-sha256 real-path))) - (reset-timestamps real-path) - (sqlite-register - #:db-file (string-append db-dir "/db.sqlite") - #:path to-register - #:references references - #:deriver deriver - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size) + (register-items (list (store-info path deriver references)) + #:prefix prefix #:state-directory state-directory + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:schema schema)) +(define %epoch + ;; When it all began. + (make-time time-utc 0 1)) + +(define* (register-items items + #:key prefix state-directory + (deduplicate? #t) + (reset-timestamps? #t) + registration-time + (schema (sql-schema))) + "Register all of ITEMS, a list of <store-info> records as returned by +'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS +must be in topological order (with leaves first.) If the database is +initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the +registration time to be recorded in the database; #f means \"now\"." + + ;; Priority for options: first what is given, then environment variables, + ;; then defaults. %state-directory, %store-directory, and + ;; %store-database-directory already handle the "environment variables / + ;; defaults" question, so we only need to choose between what is given and + ;; those. + + (define db-dir + (cond (state-directory + (string-append state-directory "/db")) + (prefix + (string-append prefix %localstatedir "/guix/db")) + (else + %store-database-directory))) + + (define store-dir + (if prefix + (string-append prefix %storedir) + %store-directory)) + + (define (register db item) + (define to-register + (if prefix + (string-append %storedir "/" (basename (store-info-item item))) + ;; note: we assume here that if path is, for example, + ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an + ;; environment variable has been used to change the store directory + ;; to /foo/bar/gnu/store, since otherwise real-path would end up + ;; being /gnu/store/thing.txt, which is probably not the right file + ;; in this case. + (store-info-item item))) + + (define real-file-name + (string-append store-dir "/" (basename (store-info-item item)))) + + (let-values (((hash nar-size) (nar-sha256 real-file-name))) + (when reset-timestamps? + (reset-timestamps real-file-name)) + (sqlite-register db #:path to-register + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size + #:time registration-time) (when deduplicate? - (deduplicate real-path hash #:store store-dir))))) + (deduplicate real-file-name hash #:store store-dir)))) + + (mkdir-p db-dir) + (parameterize ((sql-schema schema)) + (with-database (string-append db-dir "/db.sqlite") db + (for-each (cut register db <>) items)))) |