diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | Makefile.am | 17 | ||||
| -rw-r--r-- | guix/config.scm.in | 6 | ||||
| -rw-r--r-- | guix/store/database.scm | 234 | ||||
| -rw-r--r-- | tests/store-database.scm | 54 |
5 files changed, 313 insertions, 0 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 2db751ca22..eb99a5bcc1 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -75,6 +75,8 @@ (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'with-extensions 'scheme-indent-function 1)) + (eval . (put 'with-database 'scheme-indent-function 2)) + (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) (eval . (put 'eventually 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 2a0a858429..d81fce5585 100644 --- a/Makefile.am +++ b/Makefile.am @@ -257,6 +257,16 @@ MODULES += \ endif BUILD_DAEMON_OFFLOAD +# Scheme implementation of the build daemon and related functionality. +STORE_MODULES = \ + guix/store/database.scm + +if HAVE_GUILE_SQLITE3 +MODULES += $(STORE_MODULES) +else +MODULES_NOT_COMPILED += $(STORE_MODULES) +endif !HAVE_GUILE_SQLITE3 + # Internal modules with test suite support. dist_noinst_DATA = guix/tests.scm guix/tests/http.scm @@ -379,6 +389,13 @@ SCM_TESTS += \ endif +if HAVE_GUILE_SQLITE3 + +SCM_TESTS += \ + tests/store-database.scm + +endif + SH_TESTS = \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/guix/config.scm.in b/guix/config.scm.in index 8f2c4abd8e..dfe5fe0dbf 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ %store-directory %state-directory + %store-database-directory %config-directory %guix-register-program @@ -80,6 +82,10 @@ (or (getenv "NIX_STATE_DIR") (string-append %localstatedir "/guix"))) +(define %store-database-directory + (or (and=> (getenv "NIX_DB_DIR") canonicalize-path) + (string-append %state-directory "/db"))) + (define %config-directory ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'. (or (getenv "GUIX_CONFIGURATION_DIRECTORY") diff --git a/guix/store/database.scm b/guix/store/database.scm new file mode 100644 index 0000000000..4233219ba0 --- /dev/null +++ b/guix/store/database.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix store database) + #:use-module (sqlite3) + #:use-module (guix config) + #:use-module (guix serialization) + #:use-module (guix base16) + #:use-module (guix hash) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:export (sqlite-register + register-path)) + +;;; Code for working with the store database directly. + + +(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))) + (dynamic-wind noop + (lambda () + exp ...) + (lambda () + (sqlite-close db))))) + +(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)) + (result (sqlite-fold cons '() stmt))) + (sqlite-finalize stmt) + (match result + ((#(id)) id) + (_ #f)))) + +(define path-id-sql + "SELECT id FROM ValidPaths WHERE path = :path") + +(define* (path-id db path) + "If PATH exists in the 'ValidPaths' table, return its numerical +identifier. Otherwise, return #f." + (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:path path) + (let ((result (sqlite-fold cons '() stmt))) + (sqlite-finalize stmt) + (match result + ((#(id) . _) id) + (_ #f))))) + +(define update-sql + "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = +:deriver, narSize = :size WHERE id = :id") + +(define insert-sql + "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) +VALUES (:path, :hash, :time, :deriver, :size)") + +(define* (update-or-insert db #:key path deriver hash nar-size time) + "The classic update-if-exists and insert-if-doesn't feature that sqlite +doesn't exactly have... they've got something close, but it involves deleting +and re-inserting instead of updating, which causes problems with foreign keys, +of course. Returns the row id of the row that was modified or inserted." + (let ((id (path-id db path))) + (if id + (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:id id + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt) + (sqlite-finalize stmt) + (last-insert-row-id db)) + (let ((stmt (sqlite-prepare db insert-sql #:cache? #t))) + (sqlite-bind-arguments stmt + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt) ;execute it + (sqlite-finalize stmt) + (last-insert-row-id db))))) + +(define add-reference-sql + "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id +FROM ValidPaths WHERE path = :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." + (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) + (for-each (lambda (reference) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt #:referrer referrer + #:reference reference) + (sqlite-fold cons '() stmt) ;execute it + (sqlite-finalize stmt) + (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)))) + + +;;; +;;; High-level interface. +;;; + +;; XXX: Would it be better to just make WRITE-FILE give size as well? I question +;; the general utility of this approach. +(define (counting-wrapper-port output-port) + "Some custom ports don't implement GET-POSITION at all. But if we want to +figure out how many bytes are being written, we will want to use that. So this +makes a wrapper around a port which implements GET-POSITION." + (let ((byte-count 0)) + (make-custom-binary-output-port "counting-wrapper" + (lambda (bytes offset count) + (set! byte-count + (+ byte-count count)) + (put-bytevector output-port bytes + offset count) + count) + (lambda () + byte-count) + #f + (lambda () + (close-port output-port))))) + + +(define (nar-sha256 file) + "Gives the sha256 hash of a file and the size of the file in nar form." + (let-values (((port get-hash) (open-sha256-port))) + (let ((wrapper (counting-wrapper-port port))) + (write-file file wrapper) + (force-output wrapper) + (force-output port) + (let ((hash (get-hash)) + (size (port-position wrapper))) + (close-port wrapper) + (values hash size))))) + +;; 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) + ;; 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. + "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 +initialize; if STATE-DIRECTORY is given, it must be a string containing the +absolute file name to the state directory of the store being initialized. +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))) + (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)))) diff --git a/tests/store-database.scm b/tests/store-database.scm new file mode 100644 index 0000000000..1348a75c26 --- /dev/null +++ b/tests/store-database.scm @@ -0,0 +1,54 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-store-database) + #:use-module (guix tests) + #:use-module ((guix store) #:hide (register-path)) + #:use-module (guix store database) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64)) + +;; Test the (guix store database) module. + +(define %store + (open-connection-for-tests)) + + +(test-begin "store-database") + +(test-assert "register-path" + (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) + "-fake"))) + (when (valid-path? %store file) + (delete-paths %store (list file))) + (false-if-exception (delete-file file)) + + (let ((ref (add-text-to-store %store "ref-of-fake" (random-text))) + (drv (string-append file ".drv"))) + (call-with-output-file file + (cut display "This is a fake store item.\n" <>)) + (register-path file + #:references (list ref) + #:deriver drv) + + (and (valid-path? %store file) + (equal? (references %store file) (list ref)) + (null? (valid-derivers %store file)) + (null? (referrers %store file)))))) + +(test-end "store-database") |