mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
Add (gnu store database).
* guix/config.scm.in (%store-database-directory): New variable. * guix/store/database.scm: New file. * tests/store-database.scm: New file. * Makefile.am (STORE_MODULES): New variable. (MODULES, MODULES_NOT_COMPILED): Adjust accordingly. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add tests/store-database.scm. Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
parent
d59e75f3b5
commit
7f9d184d9b
5 changed files with 313 additions and 0 deletions
|
@ -75,6 +75,8 @@
|
||||||
(eval . (put 'with-imported-modules 'scheme-indent-function 1))
|
(eval . (put 'with-imported-modules 'scheme-indent-function 1))
|
||||||
(eval . (put 'with-extensions '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 'call-with-container 'scheme-indent-function 1))
|
||||||
(eval . (put 'container-excursion 'scheme-indent-function 1))
|
(eval . (put 'container-excursion 'scheme-indent-function 1))
|
||||||
(eval . (put 'eventually 'scheme-indent-function 1))
|
(eval . (put 'eventually 'scheme-indent-function 1))
|
||||||
|
|
17
Makefile.am
17
Makefile.am
|
@ -257,6 +257,16 @@ MODULES += \
|
||||||
|
|
||||||
endif BUILD_DAEMON_OFFLOAD
|
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.
|
# Internal modules with test suite support.
|
||||||
dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
|
dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
|
||||||
|
|
||||||
|
@ -379,6 +389,13 @@ SCM_TESTS += \
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
if HAVE_GUILE_SQLITE3
|
||||||
|
|
||||||
|
SCM_TESTS += \
|
||||||
|
tests/store-database.scm
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
SH_TESTS = \
|
SH_TESTS = \
|
||||||
tests/guix-build.sh \
|
tests/guix-build.sh \
|
||||||
tests/guix-download.sh \
|
tests/guix-download.sh \
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
;;; 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.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -29,6 +30,7 @@ (define-module (guix config)
|
||||||
|
|
||||||
%store-directory
|
%store-directory
|
||||||
%state-directory
|
%state-directory
|
||||||
|
%store-database-directory
|
||||||
%config-directory
|
%config-directory
|
||||||
%guix-register-program
|
%guix-register-program
|
||||||
|
|
||||||
|
@ -80,6 +82,10 @@ (define %state-directory
|
||||||
(or (getenv "NIX_STATE_DIR")
|
(or (getenv "NIX_STATE_DIR")
|
||||||
(string-append %localstatedir "/guix")))
|
(string-append %localstatedir "/guix")))
|
||||||
|
|
||||||
|
(define %store-database-directory
|
||||||
|
(or (and=> (getenv "NIX_DB_DIR") canonicalize-path)
|
||||||
|
(string-append %state-directory "/db")))
|
||||||
|
|
||||||
(define %config-directory
|
(define %config-directory
|
||||||
;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
|
;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
|
||||||
(or (getenv "GUIX_CONFIGURATION_DIRECTORY")
|
(or (getenv "GUIX_CONFIGURATION_DIRECTORY")
|
||||||
|
|
234
guix/store/database.scm
Normal file
234
guix/store/database.scm
Normal file
|
@ -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))))
|
54
tests/store-database.scm
Normal file
54
tests/store-database.scm
Normal file
|
@ -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")
|
Loading…
Reference in a new issue