* [bug#31755] [PATCH 02/19] database: Fail registration when encountering unregistered references.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 03/19] store-copy: 'read-reference-graph' returns a list of records Ludovic Courtès
` (16 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (add-reference-sql): Remove nested SELECT.
(add-references): Expect REFERENCES to be a list of ids.
(sqlite-register): Call 'path-id' for each of REFERENCES and pass it to
'add-references'.
* tests/store-database.scm ("register-path with unregistered references"):
New test.
---
guix/store/database.scm | 18 +++++++++++-------
tests/store-database.scm | 20 ++++++++++++++++++++
2 files changed, 31 insertions(+), 7 deletions(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index e81ab3dc9..d5e34ef04 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -27,6 +27,7 @@
#: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)
#:use-module (system foreign)
@@ -139,13 +140,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 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)
@@ -164,15 +163,20 @@ 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."
+\"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.
+
+Every store item in REFERENCES must already be registered."
(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))))
+ ;; 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)))))
\f
;;;
diff --git a/tests/store-database.scm b/tests/store-database.scm
index 794736859..9562055fd 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -74,4 +74,24 @@
(list (path-id db "/gnu/foo")
(path-id db "/gnu/bar")))))))
+(test-assert "register-path with unregistered references"
+ ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error
+ ;; when we try to add references that are not registered yet. Better safe
+ ;; than sorry.
+ (call-with-temporary-output-file
+ (lambda (db-file port)
+ (delete-file db-file)
+ (catch 'sqlite-error
+ (lambda ()
+ (sqlite-register #:db-file db-file
+ #:path "/gnu/foo"
+ #:references '("/gnu/bar")
+ #:deriver "/gnu/foo.drv"
+ #:hash (string-append "sha256:" (make-string 64 #\e))
+ #:nar-size 1234)
+ #f)
+ (lambda args
+ (pk 'welcome-exception! args)
+ #t)))))
+
(test-end "store-database")
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 03/19] store-copy: 'read-reference-graph' returns a list of records.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 02/19] database: Fail registration when encountering unregistered references Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 04/19] build: Require Guile-SQLite3 Ludovic Courtès
` (15 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
The previous implementation of 'read-reference-graph' was good enough
for many use cases, but it discarded the graph structure, which is
useful information in some cases.
* guix/build/store-copy.scm (<store-info>): New record type.
(read-reference-graph): Rewrite to return a list of <store-info>.
(closure-size, populate-store): Adjust accordingly.
* gnu/services/base.scm (references-file): Adjust accordingly.
* gnu/system/vm.scm (system-docker-image): Likewise.
* guix/scripts/pack.scm (squashfs-image, docker-image): Likewise.
* tests/gexp.scm ("gexp->derivation #:references-graphs"): Likewise.
---
gnu/services/base.scm | 5 +-
gnu/system/vm.scm | 6 +-
guix/build/store-copy.scm | 120 +++++++++++++++++++++++++++++++++-----
guix/scripts/pack.scm | 10 ++--
tests/gexp.scm | 17 ++++--
5 files changed, 128 insertions(+), 30 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index b34bb7132..68411439d 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1592,8 +1592,9 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(call-with-output-file #$output
(lambda (port)
- (write (call-with-input-file "graph"
- read-reference-graph)
+ (write (map store-info-item
+ (call-with-input-file "graph"
+ read-reference-graph))
port)))))
#:options `(#:local-build? #f
#:references-graphs (("graph" ,item))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 8cfbda226..2ffab15dd 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -455,8 +455,10 @@ should set REGISTER-CLOSURES? to #f."
(build-docker-image
(string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory
- (call-with-input-file (string-append "/xchg/" #$graph)
- read-reference-graph))
+ (map store-info-item
+ (call-with-input-file
+ (string-append "/xchg/" #$graph)
+ read-reference-graph)))
#$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index fe2eb6f69..bad1c09cb 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,10 +18,21 @@
(define-module (guix build store-copy)
#:use-module (guix build utils)
+ #:use-module (guix sets)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 ftw)
- #:export (read-reference-graph
+ #:use-module (ice-9 vlist)
+ #:export (store-info?
+ store-info-item
+ store-info-deriver
+ store-info-references
+
+ read-reference-graph
+
closure-size
populate-store))
@@ -34,19 +45,94 @@
;;;
;;; Code:
+;; Information about a store item as produced by #:references-graphs.
+(define-record-type <store-info>
+ (store-info item deriver references)
+ store-info?
+ (item store-info-item) ;string
+ (deriver store-info-deriver) ;#f | string
+ (references store-info-references)) ;?
+
+;; TODO: Factorize with that in (guix store).
+(define (topological-sort nodes edges)
+ "Return NODES in topological order according to EDGES. EDGES must be a
+one-argument procedure that takes a node and returns the nodes it is connected
+to."
+ (define (traverse)
+ ;; Do a simple depth-first traversal of all of PATHS.
+ (let loop ((nodes nodes)
+ (visited (setq))
+ (result '()))
+ (match nodes
+ ((head tail ...)
+ (if (set-contains? visited head)
+ (loop tail visited result)
+ (call-with-values
+ (lambda ()
+ (loop (edges head)
+ (set-insert head visited)
+ result))
+ (lambda (visited result)
+ (loop tail visited (cons head result))))))
+ (()
+ (values visited result)))))
+
+ (call-with-values traverse
+ (lambda (_ result)
+ (reverse result))))
+
(define (read-reference-graph port)
- "Return a list of store paths from the reference graph at PORT.
-The data at PORT is the format produced by #:references-graphs."
- (let loop ((line (read-line port))
- (result '()))
- (cond ((eof-object? line)
- (delete-duplicates result))
- ((string-prefix? "/" line)
- (loop (read-line port)
- (cons line result)))
- (else
- (loop (read-line port)
- result)))))
+ "Read the reference graph as produced by #:references-graphs from PORT and
+return it as a list of <store-info> records in topological order--i.e., leaves
+come first. IOW, store items in the resulting list can be registered in the
+order in which they appear.
+
+The reference graph format consists of sequences of lines like this:
+
+ FILE
+ DERIVER
+ NUMBER-OF-REFERENCES
+ REF1
+ ...
+ REFN
+
+It is meant as an internal format."
+ (let loop ((result '())
+ (table vlist-null)
+ (referrers vlist-null))
+ (match (read-line port)
+ ((? eof-object?)
+ ;; 'guix-daemon' gives us something that's in "reverse topological
+ ;; order"--i.e., leaves (items with zero references) come last. Here
+ ;; we compute the topological order that we want: leaves come first.
+ (let ((unreferenced? (lambda (item)
+ (let ((referrers (vhash-fold* cons '()
+ (store-info-item item)
+ referrers)))
+ (or (null? referrers)
+ (equal? (list item) referrers))))))
+ (topological-sort (filter unreferenced? result)
+ (lambda (item)
+ (map (lambda (item)
+ (match (vhash-assoc item table)
+ ((_ . node) node)))
+ (store-info-references item))))))
+ (item
+ (let* ((deriver (match (read-line port)
+ ("" #f)
+ (line line)))
+ (count (string->number (read-line port)))
+ (refs (unfold-right (cut >= <> count)
+ (lambda (n)
+ (read-line port))
+ 1+
+ 0))
+ (item (store-info item deriver refs)))
+ (loop (cons item result)
+ (vhash-cons (store-info-item item) item table)
+ (fold (cut vhash-cons <> item <>)
+ referrers
+ refs)))))))
(define (file-size file)
"Return the size of bytes of FILE, entering it if FILE is a directory."
@@ -72,7 +158,8 @@ The data at PORT is the format produced by #:references-graphs."
"Return an estimate of the size of the closure described by
REFERENCE-GRAPHS, a list of reference-graph files."
(define (graph-from-file file)
- (call-with-input-file file read-reference-graph))
+ (map store-info-item
+ (call-with-input-file file read-reference-graph)))
(define items
(delete-duplicates (append-map graph-from-file reference-graphs)))
@@ -88,7 +175,8 @@ REFERENCE-GRAPHS, a list of reference-graph files."
(define (things-to-copy)
;; Return the list of store files to copy to the image.
(define (graph-from-file file)
- (call-with-input-file file read-reference-graph))
+ (map store-info-item
+ (call-with-input-file file read-reference-graph)))
(delete-duplicates (append-map graph-from-file reference-graphs)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 76729d8e1..78bfd01ef 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -251,8 +251,9 @@ added to the pack."
;; ancestor directories and only keeps the basename. We fix this
;; in the following invocations of mksquashfs.
(apply invoke "mksquashfs"
- `(,@(call-with-input-file "profile"
- read-reference-graph)
+ `(,@(map store-info-item
+ (call-with-input-file "profile"
+ read-reference-graph))
,#$output
;; Do not perform duplicate checking because we
@@ -352,8 +353,9 @@ the image."
(setenv "PATH" (string-append #$archiver "/bin"))
(build-docker-image #$output
- (call-with-input-file "profile"
- read-reference-graph)
+ (map store-info-item
+ (call-with-input-file "profile"
+ read-reference-graph))
#$profile
#:system (or #$target (utsname:machine (uname)))
#:symlinks '#$symlinks
diff --git a/tests/gexp.scm b/tests/gexp.scm
index a560adfc5..83fe81154 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -615,6 +615,7 @@
`(("graph" ,two))
#:modules
'((guix build store-copy)
+ (guix sets)
(guix build utils))))
(ok? (built-derivations (list drv)))
(out -> (derivation->output-path drv)))
@@ -815,21 +816,25 @@
(two (gexp->derivation "two"
#~(symlink #$one #$output:chbouib)))
(build -> (with-imported-modules '((guix build store-copy)
+ (guix sets)
(guix build utils))
#~(begin
(use-modules (guix build store-copy))
(with-output-to-file #$output
(lambda ()
- (write (call-with-input-file "guile"
- read-reference-graph))))
+ (write (map store-info-item
+ (call-with-input-file "guile"
+ read-reference-graph)))))
(with-output-to-file #$output:one
(lambda ()
- (write (call-with-input-file "one"
- read-reference-graph))))
+ (write (map store-info-item
+ (call-with-input-file "one"
+ read-reference-graph)))))
(with-output-to-file #$output:two
(lambda ()
- (write (call-with-input-file "two"
- read-reference-graph)))))))
+ (write (map store-info-item
+ (call-with-input-file "two"
+ read-reference-graph))))))))
(drv (gexp->derivation "ref-graphs" build
#:references-graphs `(("one" ,one)
("two" ,two "chbouib")
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 04/19] build: Require Guile-SQLite3.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 02/19] database: Fail registration when encountering unregistered references Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 03/19] store-copy: 'read-reference-graph' returns a list of records Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 05/19] database: Provide a way to specify the schema location Ludovic Courtès
` (14 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
The next commits make (sqlite3) an indirect dependency of (gnu build
install), which is itself used by (guix scripts system), hence this new
requirement.
* configure.ac: Error out when $guix_cv_have_recent_guile_sqlite3 is
false. Remove HAVE_GUILE_SQLITE3 Automake conditional.
* Makefile.am (MODULES, SCM_TESTS): Remove HAVE_GUILE_SQLITE3 conditions.
* doc/guix.texi (Requirements): Add Guile-SQLite3.
* README: Ditto.
* gnu/packages/package-management.scm (guix)[propagated-inputs]: Add
GUILE-SQLITE3.
[arguments]: In 'wrap-program' phase, take guile-sqlite3 into account.
---
Makefile.am | 16 +++-------------
README | 3 ++-
configure.ac | 5 +++--
doc/guix.texi | 3 +++
gnu/packages/package-management.scm | 4 +++-
5 files changed, 14 insertions(+), 17 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 102f5a2e7..d6403c02e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -262,11 +262,7 @@ STORE_MODULES = \
guix/store/database.scm \
guix/store/deduplication.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,7 +375,9 @@ SCM_TESTS = \
tests/scripts-build.scm \
tests/containers.scm \
tests/pack.scm \
- tests/import-utils.scm
+ tests/import-utils.scm \
+ tests/store-database.scm \
+ tests/store-deduplication.scm
if HAVE_GUILE_JSON
@@ -391,14 +389,6 @@ SCM_TESTS += \
endif
-if HAVE_GUILE_SQLITE3
-
-SCM_TESTS += \
- tests/store-database.scm \
- tests/store-deduplication.scm
-
-endif
-
SH_TESTS = \
tests/guix-build.sh \
tests/guix-download.sh \
diff --git a/README b/README
index 243a6c058..e1d62763d 100644
--- a/README
+++ b/README
@@ -23,7 +23,8 @@ GNU Guix currently depends on the following packages:
- [[https://gnu.org/software/guile/][GNU Guile 2.2.x or 2.0.x]], version 2.0.13 or later
- [[https://gnupg.org/][GNU libgcrypt]]
- [[https://www.gnu.org/software/make/][GNU Make]]
- - [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled.
+ - [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled
+ - [[https://notabug.org/civodul/guile-sqlite3][Guile-SQLite3]]
- [[https://gitlab.com/guile-git/guile-git][Guile-Git]]
- [[http://www.zlib.net/][zlib]]
- optionally [[https://savannah.nongnu.org/projects/guile-json/][Guile-JSON]], for the 'guix import pypi' command
diff --git a/configure.ac b/configure.ac
index d338bfda5..b866e91b2 100644
--- a/configure.ac
+++ b/configure.ac
@@ -126,8 +126,9 @@ AM_CONDITIONAL([HAVE_GUILE_JSON], [test "x$have_guile_json" = "xyes"])
dnl Guile-Sqlite3 is used by the (guix store ...) modules.
GUIX_CHECK_GUILE_SQLITE3
-AM_CONDITIONAL([HAVE_GUILE_SQLITE3],
- [test "x$guix_cv_have_recent_guile_sqlite3" = "xyes"])
+if test "x$guix_cv_have_recent_guile_sqlite3" != "xyes"; then
+ AC_MSG_ERROR([A recent Guile-SQLite3 could not be found; please install it.])
+fi
dnl Make sure we have a full-fledged Guile.
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
diff --git a/doc/guix.texi b/doc/guix.texi
index 77bdaa50e..f73eb9c2c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -615,6 +615,9 @@ later, including 2.2.x;
Guile,, gnutls-guile, GnuTLS-Guile});
@item
@c FIXME: Specify a version number once a release has been made.
+@uref{https://notabug.org/civodul/guile-sqlite3, Guile-SQLite3};
+@item
+@c FIXME: Specify a version number once a release has been made.
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
2017 or later;
@item @url{http://zlib.net, zlib};
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 1356480b8..b8c14ee5d 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -207,12 +207,13 @@
(let* ((out (assoc-ref outputs "out"))
(guile (assoc-ref inputs "guile"))
(json (assoc-ref inputs "guile-json"))
+ (sqlite (assoc-ref inputs "guile-sqlite3"))
(git (assoc-ref inputs "guile-git"))
(bs (assoc-ref inputs
"guile-bytestructures"))
(ssh (assoc-ref inputs "guile-ssh"))
(gnutls (assoc-ref inputs "gnutls"))
- (deps (list json gnutls git bs ssh))
+ (deps (list json sqlite gnutls git bs ssh))
(effective
(read-line
(open-pipe* OPEN_READ
@@ -269,6 +270,7 @@
(propagated-inputs
`(("gnutls" ,gnutls)
("guile-json" ,guile-json)
+ ("guile-sqlite3" ,guile-sqlite3)
("guile-ssh" ,guile-ssh)
("guile-git" ,guile-git)))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 05/19] database: Provide a way to specify the schema location.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (2 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 04/19] build: Require Guile-SQLite3 Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 06/19] database: 'register-path' creates the database directory if needed Ludovic Courtès
` (13 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (sqlite-register): Add #:schema. Parameterize
'sql-schema' based on this.
(register-path): Add #:schema and pass it to 'sqlite-register'.
---
guix/store/database.scm | 30 +++++++++++++++++-------------
1 file changed, 17 insertions(+), 13 deletions(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index d5e34ef04..0f6d2e2c0 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -88,7 +88,7 @@ If FILE doesn't exist, create it and initialize it as a new database."
;; 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
@@ -157,7 +157,8 @@ ids of items referred to."
;; XXX figure out caching of statement and database objects... later
(define* (sqlite-register #:key db-file path (references '())
- deriver hash nar-size)
+ deriver hash nar-size
+ (schema (sql-schema)))
"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
@@ -167,16 +168,17 @@ base16-encoded sha256 hash of the store item denoted by PATH (prefixed with
bytes of the store item denoted by PATH after being converted to nar form.
Every store item in REFERENCES must already be registered."
- (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)))))
- ;; 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)))))
+ (parameterize ((sql-schema schema))
+ (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)))))
+ ;; 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))))))
\f
;;;
@@ -221,7 +223,8 @@ it's a directory."
(define* (register-path path
#:key (references '()) deriver prefix
- state-directory (deduplicate? #t))
+ state-directory (deduplicate? #t)
+ (schema (sql-schema)))
;; 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 /
@@ -267,6 +270,7 @@ be used internally by the daemon's build hook."
(reset-timestamps real-path)
(sqlite-register
#:db-file (string-append db-dir "/db.sqlite")
+ #:schema schema
#:path to-register
#:references references
#:deriver deriver
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 06/19] database: 'register-path' creates the database directory if needed.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (3 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 05/19] database: Provide a way to specify the schema location Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 07/19] deduplicate: Fix a couple of thinkos Ludovic Courtès
` (12 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (register-path): Call 'mkdir-p'.
---
guix/store/database.scm | 2 ++
1 file changed, 2 insertions(+)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 0f6d2e2c0..1400d0d1c 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -24,6 +24,7 @@
#:use-module (guix store deduplication)
#:use-module (guix base16)
#:use-module (guix build syscalls)
+ #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
@@ -268,6 +269,7 @@ be used internally by the daemon's build hook."
(let-values (((hash nar-size)
(nar-sha256 real-path)))
(reset-timestamps real-path)
+ (mkdir-p db-dir)
(sqlite-register
#:db-file (string-append db-dir "/db.sqlite")
#:schema schema
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 07/19] deduplicate: Fix a couple of thinkos.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (4 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 06/19] database: 'register-path' creates the database directory if needed Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 08/19] database: Remove extra SQL parameter in 'update-or-insert' Ludovic Courtès
` (11 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/deduplication.scm (get-temp-link): Turn 'args' in the 'catch'
handler into a rest argument.
(deduplicate): Use 'lstat' instead of 'file-is-directory?' to properly
handle symlinks. When iterating over the result of 'scandir', exclude
the ".links" sub-directory.
* tests/store-deduplication.scm ("deduplicate"): Create sub-directories
and call 'deduplicate' directly on STORE.
---
guix/store/deduplication.scm | 13 ++++++++-----
tests/store-deduplication.scm | 9 ++++-----
2 files changed, 12 insertions(+), 10 deletions(-)
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 4b4ac01f6..d3139eb90 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -85,7 +85,7 @@ LINK-PREFIX."
(lambda ()
(link target tempname)
tempname)
- (lambda (args)
+ (lambda args
(if (= (system-error-errno args) EEXIST)
(try (tempname-in link-prefix))
(throw 'system-error args))))))
@@ -120,12 +120,15 @@ under STORE."
(link-file (string-append links-directory "/"
(bytevector->base16-string hash))))
(mkdir-p links-directory)
- (if (file-is-directory? path)
+ (if (eq? 'directory (stat:type (lstat path)))
;; Can't hardlink directories, so hardlink their atoms.
(for-each (lambda (file)
- (unless (member file '("." ".."))
- (deduplicate file (nar-sha256 file)
- #:store store)))
+ (unless (or (member file '("." ".."))
+ (and (string=? path store)
+ (string=? file ".links")))
+ (let ((file (string-append path "/" file)))
+ (deduplicate file (nar-sha256 file)
+ #:store store))))
(scandir path))
(if (file-exists? link-file)
(false-if-system-error (EMLINK)
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index 04817a193..236172319 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -37,10 +37,12 @@
(lambda (store)
(let ((data (string->utf8 "Hello, world!"))
(identical (map (lambda (n)
- (string-append store "/" (number->string n)))
+ (string-append store "/" (number->string n)
+ "/a/b/c"))
(iota 5)))
(unique (string-append store "/unique")))
(for-each (lambda (file)
+ (mkdir-p (dirname file))
(call-with-output-file file
(lambda (port)
(put-bytevector port data))))
@@ -49,10 +51,7 @@
(lambda (port)
(put-bytevector port (string->utf8 "This is unique."))))
- (for-each (lambda (file)
- (deduplicate file (sha256 data) #:store store))
- identical)
- (deduplicate unique (nar-sha256 unique) #:store store)
+ (deduplicate store (nar-sha256 store) #:store store)
;; (system (string-append "ls -lRia " store))
(cons* (apply = (map (compose stat:ino stat) identical))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 08/19] database: Remove extra SQL parameter in 'update-or-insert'.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (5 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 07/19] deduplicate: Fix a couple of thinkos Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 09/19] database: Add #:reset-timestamps? to 'register-path' Ludovic Courtès
` (10 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (update-or-insert): Remove extra #:path
parameter.
---
guix/store/database.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 1400d0d1c..b9170dda7 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -127,7 +127,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)
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 09/19] database: Add #:reset-timestamps? to 'register-path'.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (6 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 08/19] database: Remove extra SQL parameter in 'update-or-insert' Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 10/19] database: Replace existing entries in Refs Ludovic Courtès
` (9 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (register-path): Add #:reset-timestamps? and
honor it.
---
guix/store/database.scm | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index b9170dda7..bfd2c3626 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -225,6 +225,7 @@ it's a directory."
(define* (register-path path
#:key (references '()) deriver prefix
state-directory (deduplicate? #t)
+ (reset-timestamps? #t)
(schema (sql-schema)))
;; Priority for options: first what is given, then environment variables,
;; then defaults. %state-directory, %store-directory, and
@@ -268,7 +269,8 @@ be used internally by the daemon's build hook."
(real-path (string-append store-dir "/" (basename path))))
(let-values (((hash nar-size)
(nar-sha256 real-path)))
- (reset-timestamps real-path)
+ (when reset-timestamps?
+ (reset-timestamps real-path))
(mkdir-p db-dir)
(sqlite-register
#:db-file (string-append db-dir "/db.sqlite")
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 10/19] database: Replace existing entries in Refs.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (7 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 09/19] database: Add #:reset-timestamps? to 'register-path' Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 11/19] database: 'reset-timestamps' sets file permissions as well Ludovic Courtès
` (8 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (add-reference-sql): Add "OR REPLACE".
---
guix/store/database.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index bfd2c3626..094dea3ec 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -141,7 +141,7 @@ of course. Returns the row id of the row that was modified or inserted."
(last-insert-row-id db)))))
(define add-reference-sql
- "INSERT INTO Refs (referrer, reference) VALUES (:referrer, :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
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 11/19] database: 'reset-timestamps' sets file permissions as well.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (8 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 10/19] database: Replace existing entries in Refs Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 12/19] vm: 'expression->derivation-in-linux-vm' code can now use dlopen Ludovic Courtès
` (7 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (reset-timestamps): Add 'chmod' calls.
---
guix/store/database.scm | 15 +++++----------
1 file changed, 5 insertions(+), 10 deletions(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 094dea3ec..67dfb8b0e 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -24,7 +24,8 @@
#:use-module (guix store deduplication)
#:use-module (guix base16)
#:use-module (guix build syscalls)
- #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module ((guix build utils)
+ #:select (mkdir-p executable-file?))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
@@ -189,11 +190,12 @@ Every store item in REFERENCES must already be registered."
;; 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
@@ -212,16 +214,9 @@ 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)
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 12/19] vm: 'expression->derivation-in-linux-vm' code can now use dlopen.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (9 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 11/19] database: 'reset-timestamps' sets file permissions as well Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 13/19] install: Use (guix store database) instead of 'guix-register' Ludovic Courtès
` (6 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* gnu/system/vm.scm (expression->derivation-in-linux-vm)
[user-builder]: Define in non-monadic style as 'program-file'.
[loader]: Likewise, and 'execl' USER-BUILDER instead of loading it.
(system-docker-image): Pass BUILD as the second
argument to 'expression->derivation-in-linux-vm'.
(make-iso9660-image, qemu-image): Remove call to 'reboot'.
---
gnu/system/vm.scm | 43 ++++++++++++++++++++-----------------------
1 file changed, 20 insertions(+), 23 deletions(-)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 2ffab15dd..e0fcf1f3e 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -148,12 +148,24 @@ based on the size of the closure of REFERENCES-GRAPHS.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share."
+ (define user-builder
+ (program-file "builder-in-linux-vm" exp))
+
+ (define loader
+ ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
+ ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
+ ;; Guile, which it couldn't do using the statically-linked guile used in
+ ;; the initrd. See example at
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
+ (program-file "linux-vm-loader"
+ ;; When USER-BUILDER succeeds, reboot (indicating a
+ ;; success), otherwise die, which causes a kernel panic
+ ;; ("Attempted to kill init!").
+ #~(when (zero? (system* #$user-builder))
+ (reboot))))
+
(mlet* %store-monad
- ((user-builder (gexp->file "builder-in-linux-vm" exp))
- (loader (gexp->file "linux-vm-loader"
- #~(primitive-load #$user-builder)))
- (coreutils -> (canonical-package coreutils))
- (initrd (if initrd ; use the default initrd?
+ ((initrd (if initrd ; use the default initrd?
(return initrd)
(base-initrd %linux-vm-file-systems
#:on-error 'backtrace
@@ -254,8 +266,7 @@ INPUTS is a list of inputs (as for packages)."
#:closures graphs
#:volume-id #$file-system-label
#:volume-uuid #$(and=> file-system-uuid
- uuid-bytevector))
- (reboot))))
+ uuid-bytevector)))))
#:system system
#:make-disk-image? #f
#:single-file-output? #t
@@ -373,8 +384,7 @@ the image."
#:bootcfg-location
#$(bootloader-configuration-file bootloader)
#:bootloader-installer
- #$(bootloader-installer bootloader))
- (reboot)))))
+ #$(bootloader-installer bootloader))))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
@@ -464,20 +474,7 @@ should set REGISTER-CLOSURES? to #f."
#:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> ""))))))))
(expression->derivation-in-linux-vm
- name
- ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
- ;; needs to be run by a Guile that can dlopen libgcrypt. The following
- ;; hack works around that problem by putting the "build" gexp into an
- ;; executable script (created by program-file) which, when executed, will
- ;; run using a Guile that supports dlopen. That way, the VM's initrd
- ;; Guile can just execute it via invoke, without using dlopen. See:
- ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
- (with-imported-modules `((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- ;; If we use execl instead of invoke here, the VM will crash with a
- ;; kernel panic.
- (invoke #$(program-file "build-docker-image" build))))
+ name build
#:make-disk-image? #f
#:single-file-output? #t
#:references-graphs `((,graph ,os-drv)))))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 13/19] install: Use (guix store database) instead of 'guix-register'.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (10 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 12/19] vm: 'expression->derivation-in-linux-vm' code can now use dlopen Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 14/19] database: 'sqlite-register' takes a database, not a file name Ludovic Courtès
` (5 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* gnu/build/install.scm (register-closure): Add #:reset-timestamps? and
and #:schema; honor them. Rewrite in terms of 'register-path'.
(populate-single-profile-directory): Add #:schema and honor it. Make
/var/guix/profiles and /var/guix/gcroots.
* gnu/build/vm.scm (root-partition-initializer): Pass
#:reset-timestamps? to 'register-closure'.
* gnu/system/vm.scm (not-config?): New procedure.
(guile-sqlite3&co): New variable.
(expression->derivation-in-linux-vm)[config]: New variable.
[builder]: Use 'with-extensions'.
(iso9660-image)[schema, config]: New variables.
Wrap build expression in 'with-extensions'; add 'sql-schema' call.
Remove GUIX from INPUTS.
(qemu-image)[schema, config]: New variables.
Wrap body in 'with-extensions'.
(system-docker-image)[not-config?]: Remove.
[config]: Use 'make-config.scm'.
[schema]: New variable.
[build]: Use 'with-extensions'. Add call to 'sql-schema'. Remove GUIX
from INPUTS.
* gnu/system/file-systems.scm (%store-prefix): Check whether
'%store-prefix' is defined.
* guix/scripts/pack.scm (self-contained-tarball)[not-config?]
[libgcrypt, schema]: New variables.
[build]: Wrap in 'with-extensions'. Adjust imported module list to use
'make-config.scm' for (guix config).
---
gnu/build/install.scm | 45 +++--
gnu/build/vm.scm | 1 +
gnu/system/file-systems.scm | 11 +-
gnu/system/vm.scm | 369 ++++++++++++++++++++----------------
guix/scripts/pack.scm | 209 +++++++++++---------
5 files changed, 356 insertions(+), 279 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 9e30c0d23..6cc678b44 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -18,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build install)
+ #:use-module (guix store database)
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (srfi srfi-26)
@@ -158,23 +159,31 @@ as created and modified at the Epoch."
(utime file 0 0 0 0))))
(find-files directory #:directories? #t)))
-(define* (register-closure store closure
- #:key (deduplicate? #t))
- "Register CLOSURE in STORE, where STORE is the directory name of the target
-store and CLOSURE is the name of a file containing a reference graph as used
-by 'guix-register'. As a side effect, this resets timestamps on store files
-and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the
-rest of STORE."
- (let ((status (apply system* "guix-register" "--prefix" store
- (append (if deduplicate? '() '("--no-deduplication"))
- (list closure)))))
- (unless (zero? status)
- (error "failed to register store items" closure))))
+(define* (register-closure prefix closure
+ #:key
+ (deduplicate? #t) (reset-timestamps? #t)
+ (schema (sql-schema)))
+ "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+ (let ((items (call-with-input-file closure read-reference-graph)))
+ ;; TODO: Add a procedure to register all of ITEMS at once.
+ (for-each (lambda (item)
+ (register-path (store-info-item item)
+ #:references (store-info-references item)
+ #:deriver (store-info-deriver item)
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:schema schema))
+ items)))
(define* (populate-single-profile-directory directory
#:key profile closure
deduplicate?
- register?)
+ register? schema)
"Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE.
@@ -200,11 +209,11 @@ This is used to create the self-contained tarballs with 'guix pack'."
(when register?
(register-closure (canonicalize-path directory) closure
- #:deduplicate? deduplicate?)
+ #:deduplicate? deduplicate?
+ #:schema schema)
- ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
- ;; target uses $TMPDIR. Fix that.
- (delete-file (scope "/var/guix/gcroots/profiles"))
+ (mkdir-p* "/var/guix/profiles")
+ (mkdir-p* "/var/guix/gcroots")
(symlink* "/var/guix/profiles"
"/var/guix/gcroots/profiles"))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index fa3ce7790..37639f723 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -354,6 +354,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(for-each (lambda (closure)
(register-closure target
(string-append "/xchg/" closure)
+ #:reset-timestamps? copy-closures?
#:deduplicate? deduplicate?))
closures)
(unless copy-closures?
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 2b5948256..393dd0df7 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -194,10 +194,15 @@
;; differs from user to user.
(define (%store-prefix)
"Return the store prefix."
- (cond ((resolve-module '(guix store) #:ensure #f)
+ ;; Note: If we have (guix store database) in the search path and we do *not*
+ ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
+ ;; with one sub-module.
+ (cond ((and=> (resolve-module '(guix store) #:ensure #f)
+ (lambda (store)
+ (module-variable store '%store-prefix)))
=>
- (lambda (store)
- ((module-ref store '%store-prefix))))
+ (lambda (variable)
+ ((variable-ref variable))))
((getenv "NIX_STORE")
=> identity)
(else
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index e0fcf1f3e..f3a7b630e 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -34,6 +34,7 @@
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix base32)
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module ((gnu build vm)
#:select (qemu-command))
@@ -50,7 +51,6 @@
#:use-module (gnu packages disk)
#:use-module (gnu packages zile)
#:use-module (gnu packages linux)
- #:use-module (gnu packages package-management)
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
#:use-module (gnu packages admin)
@@ -116,6 +116,19 @@
(options "trans=virtio")
(check? #f))))
+(define not-config?
+ ;; Select (guix …) and (gnu …) modules, except (guix config).
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix rest ...) #t)
+ (('gnu rest ...) #t)
+ (rest #f)))
+
+(define guile-sqlite3&co
+ ;; Guile-SQLite3 and its propagated inputs.
+ (cons guile-sqlite3
+ (package-transitive-propagated-inputs guile-sqlite3)))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
@@ -148,6 +161,10 @@ based on the size of the closure of REFERENCES-GRAPHS.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share."
+ (define config
+ ;; (guix config) module for consumption by (guix gcrypt).
+ (make-config.scm #:libgcrypt libgcrypt))
+
(define user-builder
(program-file "builder-in-linux-vm" exp))
@@ -175,40 +192,44 @@ made available under the /xchg CIFS share."
(define builder
;; Code that launches the VM that evaluates EXP.
- (with-imported-modules (source-module-closure '((guix build utils)
- (gnu build vm)))
- #~(begin
- (use-modules (guix build utils)
- (gnu build vm))
+ (with-extensions guile-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build utils)
+ (gnu build vm))
+ #:select? not-config?)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build vm))
- (let* ((inputs '#$(list qemu coreutils))
- (linux (string-append #$linux "/"
- #$(system-linux-image-file-name)))
- (initrd (string-append #$initrd "/initrd"))
- (loader #$loader)
- (graphs '#$(match references-graphs
- (((graph-files . _) ...) graph-files)
- (_ #f)))
- (size #$(if (eq? 'guess disk-image-size)
- #~(+ (* 70 (expt 2 20)) ;ESP
- (estimated-partition-size graphs))
- disk-image-size)))
+ (let* ((inputs '#$(list qemu (canonical-package coreutils)))
+ (linux (string-append #$linux "/"
+ #$(system-linux-image-file-name)))
+ (initrd (string-append #$initrd "/initrd"))
+ (loader #$loader)
+ (graphs '#$(match references-graphs
+ (((graph-files . _) ...) graph-files)
+ (_ #f)))
+ (size #$(if (eq? 'guess disk-image-size)
+ #~(+ (* 70 (expt 2 20)) ;ESP
+ (estimated-partition-size graphs))
+ disk-image-size)))
- (set-path-environment-variable "PATH" '("bin") inputs)
+ (set-path-environment-variable "PATH" '("bin") inputs)
- (load-in-linux-vm loader
- #:output #$output
- #:linux linux #:initrd initrd
- #:memory-size #$memory-size
- #:make-disk-image? #$make-disk-image?
- #:single-file-output? #$single-file-output?
- ;; FIXME: ‘target-arm32?’ may not operate on
- ;; the right system/target values. Rewrite
- ;; using ‘let-system’ when available.
- #:target-arm32? #$(target-arm32?)
- #:disk-image-format #$disk-image-format
- #:disk-image-size size
- #:references-graphs graphs)))))
+ (load-in-linux-vm loader
+ #:output #$output
+ #:linux linux #:initrd initrd
+ #:memory-size #$memory-size
+ #:make-disk-image? #$make-disk-image?
+ #:single-file-output? #$single-file-output?
+ ;; FIXME: ‘target-arm32?’ may not operate on
+ ;; the right system/target values. Rewrite
+ ;; using ‘let-system’ when available.
+ #:target-arm32? #$(target-arm32?)
+ #:disk-image-format #$disk-image-format
+ #:disk-image-size size
+ #:references-graphs graphs))))))
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
@@ -231,42 +252,56 @@ made available under the /xchg CIFS share."
"Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)."
+ (define config
+ (make-config.scm #:libgcrypt libgcrypt))
+
+ (define schema
+ (and register-closures?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
+
(expression->derivation-in-linux-vm
name
- (with-imported-modules (source-module-closure '((gnu build vm)
- (guix build utils)))
- #~(begin
- (use-modules (gnu build vm)
- (guix build utils))
+ (with-extensions guile-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure '((gnu build vm)
+ (guix store database)
+ (guix build utils))
+ #:select? not-config?)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (gnu build vm)
+ (guix store database)
+ (guix build utils))
- (let ((inputs
- '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
- (map canonical-package
- (list sed grep coreutils findutils gawk))
- (if register-closures? (list guix) '())))
+ (sql-schema #$schema)
+ (let ((inputs
+ '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))))
- (graphs '#$(match inputs
- (((names . _) ...)
- names)))
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-iso9660-image #$(bootloader-package bootloader)
- #$bootcfg-drv
- #$os-drv
- "/xchg/guixsd.iso"
- #:register-closures? #$register-closures?
- #:closures graphs
- #:volume-id #$file-system-label
- #:volume-uuid #$(and=> file-system-uuid
- uuid-bytevector)))))
+ (graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (make-iso9660-image #$(bootloader-package bootloader)
+ #$bootcfg-drv
+ #$os-drv
+ "/xchg/guixsd.iso"
+ #:register-closures? #$register-closures?
+ #:closures graphs
+ #:volume-id #$file-system-label
+ #:volume-uuid #$(and=> file-system-uuid
+ uuid-bytevector))))))
#:system system
#:make-disk-image? #f
#:single-file-output? #t
@@ -301,90 +336,104 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in
the image."
+ (define config
+ (make-config.scm #:libgcrypt libgcrypt))
+
+ (define schema
+ (and register-closures?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
+
(expression->derivation-in-linux-vm
name
- (with-imported-modules (source-module-closure '((gnu build bootloader)
- (gnu build vm)
- (guix build utils)))
- #~(begin
- (use-modules (gnu build bootloader)
- (gnu build vm)
- (guix build utils)
- (srfi srfi-26)
- (ice-9 binary-ports))
+ (with-extensions guile-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure '((gnu build vm)
+ (gnu build bootloader)
+ (guix store database)
+ (guix build utils))
+ #:select? not-config?)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (gnu build bootloader)
+ (gnu build vm)
+ (guix store database)
+ (guix build utils)
+ (srfi srfi-26)
+ (ice-9 binary-ports))
- (let ((inputs
- '#$(append (list qemu parted e2fsprogs dosfstools)
- (map canonical-package
- (list sed grep coreutils findutils gawk))
- (if register-closures? (list guix) '())))
+ (sql-schema #$schema)
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
+ (let ((inputs
+ '#$(append (list qemu parted e2fsprogs dosfstools)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
- (let* ((graphs '#$(match inputs
- (((names . _) ...)
- names)))
- (initialize (root-partition-initializer
- #:closures graphs
- #:copy-closures? #$copy-inputs?
- #:register-closures? #$register-closures?
- #:system-directory #$os-drv))
- (root-size #$(if (eq? 'guess disk-image-size)
- #~(max
- ;; Minimum 20 MiB root size
- (* 20 (expt 2 20))
- (estimated-partition-size
- (map (cut string-append "/xchg/" <>)
- graphs)))
- (- disk-image-size
- (* 50 (expt 2 20)))))
- (partitions
- (append
- (list (partition
- (size root-size)
- (label #$file-system-label)
- (uuid #$(and=> file-system-uuid
- uuid-bytevector))
- (file-system #$file-system-type)
- (flags '(boot))
- (initializer initialize)))
- ;; Append a small EFI System Partition for use with UEFI
- ;; bootloaders if we are not targeting ARM because UEFI
- ;; support in U-Boot is experimental.
- ;;
- ;; FIXME: ‘target-arm32?’ may be not operate on the right
- ;; system/target values. Rewrite using ‘let-system’ when
- ;; available.
- (if #$(target-arm32?)
- '()
- (list (partition
- ;; The standalone grub image is about 10MiB, but
- ;; leave some room for custom or multiple images.
- (size (* 40 (expt 2 20)))
- (label "GNU-ESP") ;cosmetic only
- ;; Use "vfat" here since this property is used
- ;; when mounting. The actual FAT-ness is based
- ;; on file system size (16 in this case).
- (file-system "vfat")
- (flags '(esp))))))))
- (initialize-hard-disk "/dev/vda"
- #:partitions partitions
- #:grub-efi #$grub-efi
- #:bootloader-package
- #$(bootloader-package bootloader)
- #:bootcfg #$bootcfg-drv
- #:bootcfg-location
- #$(bootloader-configuration-file bootloader)
- #:bootloader-installer
- #$(bootloader-installer bootloader))))))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+ (let* ((graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
+ #:system-directory #$os-drv))
+ (root-size #$(if (eq? 'guess disk-image-size)
+ #~(max
+ ;; Minimum 20 MiB root size
+ (* 20 (expt 2 20))
+ (estimated-partition-size
+ (map (cut string-append "/xchg/" <>)
+ graphs)))
+ (- disk-image-size
+ (* 50 (expt 2 20)))))
+ (partitions
+ (append
+ (list (partition
+ (size root-size)
+ (label #$file-system-label)
+ (uuid #$(and=> file-system-uuid
+ uuid-bytevector))
+ (file-system #$file-system-type)
+ (flags '(boot))
+ (initializer initialize)))
+ ;; Append a small EFI System Partition for use with UEFI
+ ;; bootloaders if we are not targeting ARM because UEFI
+ ;; support in U-Boot is experimental.
+ ;;
+ ;; FIXME: ‘target-arm32?’ may be not operate on the right
+ ;; system/target values. Rewrite using ‘let-system’ when
+ ;; available.
+ (if #$(target-arm32?)
+ '()
+ (list (partition
+ ;; The standalone grub image is about 10MiB, but
+ ;; leave some room for custom or multiple images.
+ (size (* 40 (expt 2 20)))
+ (label "GNU-ESP") ;cosmetic only
+ ;; Use "vfat" here since this property is used
+ ;; when mounting. The actual FAT-ness is based
+ ;; on file system size (16 in this case).
+ (file-system "vfat")
+ (flags '(esp))))))))
+ (initialize-hard-disk "/dev/vda"
+ #:partitions partitions
+ #:grub-efi #$grub-efi
+ #:bootloader-package
+ #$(bootloader-package bootloader)
+ #:bootcfg #$bootcfg-drv
+ #:bootcfg-location
+ #$(bootloader-configuration-file bootloader)
+ #:bootloader-installer
+ #$(bootloader-installer bootloader)))))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
@@ -402,49 +451,41 @@ makes sense when you want to build a GuixSD Docker image that has Guix
installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
image just contains a web server that is started by the Shepherd), then you
should set REGISTER-CLOSURES? to #f."
- (define not-config?
- (match-lambda
- (('guix 'config) #f)
- (('guix rest ...) #t)
- (('gnu rest ...) #t)
- (rest #f)))
-
(define config
;; (guix config) module for consumption by (guix gcrypt).
- (scheme-file "gcrypt-config.scm"
- #~(begin
- (define-module (guix config)
- #:export (%libgcrypt))
+ (make-config.scm #:libgcrypt libgcrypt))
- ;; XXX: Work around <http://bugs.gnu.org/15602>.
- (eval-when (expand load eval)
- (define %libgcrypt
- #+(file-append libgcrypt "/lib/libgcrypt"))))))
+ (define schema
+ (and register-closures?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz"))
(graph -> "system-graph"))
(define build
- (with-extensions (list guile-json) ;for (guix docker)
+ (with-extensions (cons guile-json ;for (guix docker)
+ guile-sqlite3&co) ;for (guix store database)
(with-imported-modules `(,@(source-module-closure
'((guix docker)
+ (guix store database)
(guix build utils)
+ (guix build store-copy)
(gnu build vm))
#:select? not-config?)
- (guix build store-copy)
((guix config) => ,config))
#~(begin
(use-modules (guix docker)
(guix build utils)
(gnu build vm)
(srfi srfi-19)
- (guix build store-copy))
+ (guix build store-copy)
+ (guix store database))
- (let* ((inputs '#$(append (list tar)
- (if register-closures?
- (list guix)
- '())))
- ;; This initializer requires elevated privileges that are
+ ;; Set the SQL schema location.
+ (sql-schema #$schema)
+
+ (let* (;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM.
@@ -459,7 +500,7 @@ should set REGISTER-CLOSURES? to #f."
;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root"))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
(mkdir root-directory)
(initialize root-directory)
(build-docker-image
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 78bfd01ef..ed876b259 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -35,6 +35,7 @@
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module (gnu packages compression)
@@ -101,113 +102,133 @@ with a properly initialized store database.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack."
+ (define not-config?
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix _ ...) #t)
+ (('gnu _ ...) #t)
+ (_ #f)))
+
+ (define libgcrypt
+ (module-ref (resolve-interface '(gnu packages gnupg))
+ 'libgcrypt))
+
+ (define schema
+ (and localstatedir?
+ (local-file (search-path %load-path
+ "guix/store/schema.sql"))))
+
(define build
- (with-imported-modules (source-module-closure
- '((guix build utils)
- (guix build union)
- (guix build store-copy)
- (gnu build install)))
- #~(begin
- (use-modules (guix build utils)
- ((guix build union) #:select (relative-file-name))
- (gnu build install)
- (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 match))
+ (with-imported-modules `(((guix config)
+ => ,(make-config.scm
+ #:libgcrypt libgcrypt))
+ ,@(source-module-closure
+ `((guix build utils)
+ (guix build union)
+ (guix build store-copy)
+ (gnu build install))
+ #:select? not-config?))
+ (with-extensions (cons guile-sqlite3
+ (package-transitive-propagated-inputs
+ guile-sqlite3))
+ #~(begin
+ (use-modules (guix build utils)
+ ((guix build union) #:select (relative-file-name))
+ (gnu build install)
+ (srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 match))
- (define %root "root")
+ (define %root "root")
- (define symlink->directives
- ;; Return "populate directives" to make the given symlink and its
- ;; parent directories.
- (match-lambda
- ((source '-> target)
- (let ((target (string-append #$profile "/" target))
- (parent (dirname source)))
- ;; Never add a 'directory' directive for "/" so as to
- ;; preserve its ownnership when extracting the archive (see
- ;; below), and also because this would lead to adding the
- ;; same entries twice in the tarball.
- `(,@(if (string=? parent "/")
- '()
- `((directory ,parent)))
- (,source
- -> ,(relative-file-name parent target)))))))
+ (define symlink->directives
+ ;; Return "populate directives" to make the given symlink and its
+ ;; parent directories.
+ (match-lambda
+ ((source '-> target)
+ (let ((target (string-append #$profile "/" target))
+ (parent (dirname source)))
+ ;; Never add a 'directory' directive for "/" so as to
+ ;; preserve its ownnership when extracting the archive (see
+ ;; below), and also because this would lead to adding the
+ ;; same entries twice in the tarball.
+ `(,@(if (string=? parent "/")
+ '()
+ `((directory ,parent)))
+ (,source
+ -> ,(relative-file-name parent target)))))))
- (define directives
- ;; Fully-qualified symlinks.
- (append-map symlink->directives '#$symlinks))
+ (define directives
+ ;; Fully-qualified symlinks.
+ (append-map symlink->directives '#$symlinks))
- ;; The --sort option was added to GNU tar in version 1.28, released
- ;; 2014-07-28. For testing, we use the bootstrap tar, which is
- ;; older and doesn't support it.
- (define tar-supports-sort?
- (zero? (system* (string-append #+archiver "/bin/tar")
- "cf" "/dev/null" "--files-from=/dev/null"
- "--sort=name")))
+ ;; The --sort option was added to GNU tar in version 1.28, released
+ ;; 2014-07-28. For testing, we use the bootstrap tar, which is
+ ;; older and doesn't support it.
+ (define tar-supports-sort?
+ (zero? (system* (string-append #+archiver "/bin/tar")
+ "cf" "/dev/null" "--files-from=/dev/null"
+ "--sort=name")))
- ;; We need Guix here for 'guix-register'.
- (setenv "PATH"
- (string-append #$(if localstatedir?
- (file-append guix "/sbin:")
- "")
- #$archiver "/bin"))
+ ;; Add 'tar' to the search path.
+ (setenv "PATH" #+(file-append archiver "/bin"))
- ;; Note: there is not much to gain here with deduplication and there
- ;; is the overhead of the '.links' directory, so turn it off.
- ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
- ;; with hard links:
- ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
- (populate-single-profile-directory %root
- #:profile #$profile
- #:closure "profile"
- #:deduplicate? #f
- #:register? #$localstatedir?)
+ ;; Note: there is not much to gain here with deduplication and there
+ ;; is the overhead of the '.links' directory, so turn it off.
+ ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
+ ;; with hard links:
+ ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
+ (populate-single-profile-directory %root
+ #:profile #$profile
+ #:closure "profile"
+ #:deduplicate? #f
+ #:register? #$localstatedir?
+ #:schema #$schema)
- ;; Create SYMLINKS.
- (for-each (cut evaluate-populate-directive <> %root)
- directives)
+ ;; Create SYMLINKS.
+ (for-each (cut evaluate-populate-directive <> %root)
+ directives)
- ;; Create the tarball. Use GNU format so there's no file name
- ;; length limitation.
- (with-directory-excursion %root
- (exit
- (zero? (apply system* "tar"
- "-I"
- (string-join '#+(compressor-command compressor))
- "--format=gnu"
+ ;; Create the tarball. Use GNU format so there's no file name
+ ;; length limitation.
+ (with-directory-excursion %root
+ (exit
+ (zero? (apply system* "tar"
+ "-I"
+ (string-join '#+(compressor-command compressor))
+ "--format=gnu"
- ;; Avoid non-determinism in the archive. Use
- ;; mtime = 1, not zero, because that is what the
- ;; daemon does for files in the store (see the
- ;; 'mtimeStore' constant in local-store.cc.)
- (if tar-supports-sort? "--sort=name" "--mtime=@1")
- "--mtime=@1" ;for files in /var/guix
- "--owner=root:0"
- "--group=root:0"
+ ;; Avoid non-determinism in the archive. Use
+ ;; mtime = 1, not zero, because that is what the
+ ;; daemon does for files in the store (see the
+ ;; 'mtimeStore' constant in local-store.cc.)
+ (if tar-supports-sort? "--sort=name" "--mtime=@1")
+ "--mtime=@1" ;for files in /var/guix
+ "--owner=root:0"
+ "--group=root:0"
- "--check-links"
- "-cvf" #$output
- ;; Avoid adding / and /var to the tarball, so
- ;; that the ownership and permissions of those
- ;; directories will not be overwritten when
- ;; extracting the archive. Do not include /root
- ;; because the root account might have a
- ;; different home directory.
- #$@(if localstatedir?
- '("./var/guix")
- '())
+ "--check-links"
+ "-cvf" #$output
+ ;; Avoid adding / and /var to the tarball, so
+ ;; that the ownership and permissions of those
+ ;; directories will not be overwritten when
+ ;; extracting the archive. Do not include /root
+ ;; because the root account might have a
+ ;; different home directory.
+ #$@(if localstatedir?
+ '("./var/guix")
+ '())
- (string-append "." (%store-directory))
+ (string-append "." (%store-directory))
- (delete-duplicates
- (filter-map (match-lambda
- (('directory directory)
- (string-append "." directory))
- ((source '-> _)
- (string-append "." source))
- (_ #f))
- directives)))))))))
+ (delete-duplicates
+ (filter-map (match-lambda
+ (('directory directory)
+ (string-append "." directory))
+ ((source '-> _)
+ (string-append "." source))
+ (_ #f))
+ directives))))))))))
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 14/19] database: 'sqlite-register' takes a database, not a file name.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (11 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 13/19] install: Use (guix store database) instead of 'guix-register' Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 15/19] database: Add 'register-items' Ludovic Courtès
` (4 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (sqlite-register): Remove #:db-file and add
'db' parameter. Remove #:schema and 'parameterize'.
(register-path): Wrap 'sqlite-register' call in 'with-database' and in
'parameterize'.
* tests/store-database.scm ("new database")
("register-path with unregistered references"): Adjust accordingly.
---
guix/store/database.scm | 57 ++++++++++++++++++----------------------
tests/store-database.scm | 40 ++++++++++++++--------------
2 files changed, 46 insertions(+), 51 deletions(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 67dfb8b0e..1e5e3bcc7 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -157,30 +157,24 @@ ids of items referred to."
(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
- (schema (sql-schema)))
- "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.
+(define* (sqlite-register db #:key path (references '())
+ deriver hash nar-size)
+ "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.
Every store item in REFERENCES must already be registered."
- (parameterize ((sql-schema schema))
- (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)))))
- ;; 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))))))
+ (let ((id (update-or-insert db #:path path
+ #:deriver deriver
+ #:hash hash
+ #:nar-size nar-size
+ #:time (time-second (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))))
\f
;;;
@@ -267,15 +261,16 @@ be used internally by the daemon's build hook."
(when reset-timestamps?
(reset-timestamps real-path))
(mkdir-p db-dir)
- (sqlite-register
- #:db-file (string-append db-dir "/db.sqlite")
- #:schema schema
- #:path to-register
- #:references references
- #:deriver deriver
- #:hash (string-append "sha256:"
- (bytevector->base16-string hash))
- #:nar-size nar-size)
+ (parameterize ((sql-schema schema))
+ (with-database (string-append db-dir "/db.sqlite") db
+ (sqlite-register
+ db
+ #:path to-register
+ #:references references
+ #:deriver deriver
+ #:hash (string-append "sha256:"
+ (bytevector->base16-string hash))
+ #:nar-size nar-size)))
(when deduplicate?
(deduplicate real-path hash #:store store-dir)))))
diff --git a/tests/store-database.scm b/tests/store-database.scm
index 9562055fd..22c356679 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -57,20 +57,20 @@
(call-with-temporary-output-file
(lambda (db-file port)
(delete-file db-file)
- (sqlite-register #:db-file db-file
- #:path "/gnu/foo"
- #:references '()
- #:deriver "/gnu/foo.drv"
- #:hash (string-append "sha256:" (make-string 64 #\e))
- #:nar-size 1234)
- (sqlite-register #:db-file db-file
- #:path "/gnu/bar"
- #:references '("/gnu/foo")
- #:deriver "/gnu/bar.drv"
- #:hash (string-append "sha256:" (make-string 64 #\a))
- #:nar-size 4321)
- (let ((path-id (@@ (guix store database) path-id)))
- (with-database db-file db
+ (with-database db-file db
+ (sqlite-register db
+ #:path "/gnu/foo"
+ #:references '()
+ #:deriver "/gnu/foo.drv"
+ #:hash (string-append "sha256:" (make-string 64 #\e))
+ #:nar-size 1234)
+ (sqlite-register db
+ #:path "/gnu/bar"
+ #:references '("/gnu/foo")
+ #:deriver "/gnu/bar.drv"
+ #:hash (string-append "sha256:" (make-string 64 #\a))
+ #:nar-size 4321)
+ (let ((path-id (@@ (guix store database) path-id)))
(list (path-id db "/gnu/foo")
(path-id db "/gnu/bar")))))))
@@ -83,12 +83,12 @@
(delete-file db-file)
(catch 'sqlite-error
(lambda ()
- (sqlite-register #:db-file db-file
- #:path "/gnu/foo"
- #:references '("/gnu/bar")
- #:deriver "/gnu/foo.drv"
- #:hash (string-append "sha256:" (make-string 64 #\e))
- #:nar-size 1234)
+ (with-database db-file db
+ (sqlite-register db #:path "/gnu/foo"
+ #:references '("/gnu/bar")
+ #:deriver "/gnu/foo.drv"
+ #:hash (string-append "sha256:" (make-string 64 #\e))
+ #:nar-size 1234))
#f)
(lambda args
(pk 'welcome-exception! args)
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 15/19] database: Add 'register-items'.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (12 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 14/19] database: 'sqlite-register' takes a database, not a file name Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 16/19] install: Use 'reset-timestamps' from (guix store database) Ludovic Courtès
` (3 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/build/store-copy.scm (store-info): Export.
* guix/store/database.scm (register-items): New procedure.
(register-path): Implement in terms of 'register-items'.
* gnu/build/install.scm (register-closure): Use 'register-items' instead
of 'for-each' and 'register-path'.
---
gnu/build/install.scm | 15 ++---
guix/build/store-copy.scm | 1 +
guix/store/database.scm | 113 ++++++++++++++++++++++----------------
3 files changed, 72 insertions(+), 57 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 6cc678b44..82eb63d72 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -169,16 +169,11 @@ produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph)))
- ;; TODO: Add a procedure to register all of ITEMS at once.
- (for-each (lambda (item)
- (register-path (store-info-item item)
- #:references (store-info-references item)
- #:deriver (store-info-deriver item)
- #:prefix prefix
- #:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
- #:schema schema))
- items)))
+ (register-items items
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:schema schema)))
(define* (populate-single-profile-directory directory
#:key profile closure
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index bad1c09cb..2d9590d16 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -27,6 +27,7 @@
#:use-module (ice-9 ftw)
#:use-module (ice-9 vlist)
#:export (store-info?
+ store-info
store-info-item
store-info-deriver
store-info-references
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 1e5e3bcc7..3dbe5270a 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -26,6 +26,7 @@
#: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)
@@ -37,6 +38,7 @@
with-database
sqlite-register
register-path
+ register-items
reset-timestamps))
;;; Code for working with the store database directly.
@@ -216,11 +218,6 @@ it's a directory. While at it, canonicalize file permissions."
state-directory (deduplicate? #t)
(reset-timestamps? #t)
(schema (sql-schema)))
- ;; 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
@@ -230,47 +227,69 @@ 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)))
+ (register-items (list (store-info path deriver references))
+ #:prefix prefix #:state-directory state-directory
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:schema schema))
+
+(define* (register-items items
+ #:key prefix state-directory
+ (deduplicate? #t)
+ (reset-timestamps? #t)
+ (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."
+
+ ;; 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-path))
- (mkdir-p db-dir)
- (parameterize ((sql-schema schema))
- (with-database (string-append db-dir "/db.sqlite") db
- (sqlite-register
- db
- #:path to-register
- #:references references
- #:deriver deriver
- #:hash (string-append "sha256:"
- (bytevector->base16-string hash))
- #:nar-size nar-size)))
-
+ (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)
(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))))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 16/19] install: Use 'reset-timestamps' from (guix store database).
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (13 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 15/19] database: Add 'register-items' Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 17/19] database: Allow for deterministic database construction Ludovic Courtès
` (2 subsequent siblings)
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* gnu/build/install.scm (reset-timestamps): Remove.
* gnu/build/vm.scm: Use 'reset-timestamps' from (guix store database).
---
gnu/build/install.scm | 15 ---------------
gnu/build/vm.scm | 1 +
guix/store/database.scm | 1 -
3 files changed, 1 insertion(+), 16 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 82eb63d72..5e84cd6f6 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -26,7 +26,6 @@
#:export (install-boot-config
evaluate-populate-directive
populate-root-file-system
- reset-timestamps
register-closure
populate-single-profile-directory))
@@ -145,20 +144,6 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
(try))
(apply throw args)))))))
-(define (reset-timestamps directory)
- "Reset the timestamps of all the files under DIRECTORY, so that they appear
-as created and modified at the Epoch."
- (display "clearing file timestamps...\n")
- (for-each (lambda (file)
- (let ((s (lstat file)))
- ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
- ;; the timestamp of symlinks cannot be changed, and there are
- ;; symlinks here pointing to /gnu/store, which is the host,
- ;; read-only store.
- (unless (eq? (stat:type s) 'symlink)
- (utime file 0 0 0 0))))
- (find-files directory #:directories? #t)))
-
(define* (register-closure prefix closure
#:key
(deduplicate? #t) (reset-timestamps? #t)
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 37639f723..803cd5996 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -25,6 +25,7 @@
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
+ #:use-module ((guix store database) #:select (reset-timestamps))
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
#:use-module (gnu system uuid)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 3dbe5270a..82938455b 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -183,7 +183,6 @@ Every store item in REFERENCES must already be registered."
;;; 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. While at it, canonicalize file permissions."
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 17/19] database: Allow for deterministic database construction.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (14 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 16/19] install: Use 'reset-timestamps' from (guix store database) Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 18/19] store: Remove 'register-path' Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 19/19] Remove 'guix-register' and its traces Ludovic Courtès
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store/database.scm (sqlite-register): Add #:time.
(%epoch): New variable.
(register-items): Add #:registration-time. Pass #:time to
'sqlite-register'.
* gnu/build/install.scm (register-closure): Pass #:registration-time.
---
gnu/build/install.scm | 1 +
guix/store/database.scm | 21 ++++++++++++++++-----
2 files changed, 17 insertions(+), 5 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 5e84cd6f6..06ecb3995 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -158,6 +158,7 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
+ #:registration-time %epoch
#:schema schema)))
(define* (populate-single-profile-directory directory
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 82938455b..05b2ba6c3 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -39,6 +39,7 @@
sqlite-register
register-path
register-items
+ %epoch
reset-timestamps))
;;; Code for working with the store database directly.
@@ -160,19 +161,22 @@ ids of items referred to."
references)))
(define* (sqlite-register db #:key path (references '())
- deriver hash nar-size)
+ 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.
+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 (current-time time-utc)))))
+ #: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
@@ -232,15 +236,21 @@ be used internally by the daemon's build hook."
#: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."
+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
@@ -284,7 +294,8 @@ initially empty, apply SCHEMA to initialize it."
#:deriver (store-info-deriver item)
#:hash (string-append "sha256:"
(bytevector->base16-string hash))
- #:nar-size nar-size)
+ #:nar-size nar-size
+ #:time registration-time)
(when deduplicate?
(deduplicate real-file-name hash #:store store-dir))))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 18/19] store: Remove 'register-path'.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (15 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 17/19] database: Allow for deterministic database construction Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
2018-06-08 9:34 ` [bug#31755] [PATCH 19/19] Remove 'guix-register' and its traces Ludovic Courtès
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* guix/store.scm (register-path): Remove.
* guix/nar.scm: Use (guix store database).
* guix/scripts/system.scm: Likewise.
* tests/store-database.scm: Remove #:hide (register-path).
* tests/store.scm ("register-path"): Remove.
---
guix/nar.scm | 3 ++-
guix/scripts/system.scm | 1 +
guix/store.scm | 29 -----------------------------
tests/store-database.scm | 2 +-
tests/store.scm | 22 +---------------------
5 files changed, 5 insertions(+), 52 deletions(-)
diff --git a/guix/nar.scm b/guix/nar.scm
index 9b4c60823..3556de137 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -1,5 +1,5 @@
;;; 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, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -23,6 +23,7 @@
#:use-module ((guix build utils)
#:select (delete-file-recursively with-directory-excursion))
#:use-module (guix store)
+ #:use-module (guix store database)
#:use-module (guix ui) ; for '_'
#:use-module (guix hash)
#:use-module (guix pki)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 766cab1aa..23c45cc5a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -23,6 +23,7 @@
#:use-module (guix config)
#:use-module (guix ui)
#:use-module (guix store)
+ #:autoload (guix store database) (register-path)
#:use-module (guix grafts)
#:use-module (guix gexp)
#:use-module (guix derivations)
diff --git a/guix/store.scm b/guix/store.scm
index 6742611c6..773d53e82 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -122,8 +122,6 @@
current-build-output-port
- register-path
-
%store-monad
store-bind
store-return
@@ -1301,33 +1299,6 @@ The result is always the empty list unless the daemon was started with
This makes sense only when the daemon was started with '--cache-failures'."
boolean)
-(define* (register-path path
- #:key (references '()) deriver prefix
- state-directory)
- "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
-not #f, it must be the name of the directory containing the new store to
-initialize; if STATE-DIRECTORY is not #f, 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."
- ;; Currently this is implemented by calling out to the fine C++ blob.
- (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program
- `(,@(if prefix
- `("--prefix" ,prefix)
- '())
- ,@(if state-directory
- `("--state-directory" ,state-directory)
- '())))))
- (and pipe
- (begin
- (format pipe "~a~%~a~%~a~%"
- path (or deriver "") (length references))
- (for-each (cut format pipe "~a~%" <>) references)
- (zero? (close-pipe pipe))))))
-
\f
;;;
;;; Store monad.
diff --git a/tests/store-database.scm b/tests/store-database.scm
index 22c356679..fcae66e2d 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -18,7 +18,7 @@
(define-module (test-store-database)
#:use-module (guix tests)
- #:use-module ((guix store) #:hide (register-path))
+ #:use-module (guix store)
#:use-module (guix store database)
#:use-module ((guix utils) #:select (call-with-temporary-output-file))
#:use-module (srfi srfi-26)
diff --git a/tests/store.scm b/tests/store.scm
index fdf3be33f..afecec940 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -777,26 +777,6 @@
(pk 'corrupt-imported imported)
#f)))))
-(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-assert "verify-store"
(let* ((text (random-text))
(file1 (add-text-to-store %store "foo" text))
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread* [bug#31755] [PATCH 19/19] Remove 'guix-register' and its traces.
2018-06-08 9:34 ` [bug#31755] [PATCH 01/19] database: 'with-database' can now initialize new databases Ludovic Courtès
` (16 preceding siblings ...)
2018-06-08 9:34 ` [bug#31755] [PATCH 18/19] store: Remove 'register-path' Ludovic Courtès
@ 2018-06-08 9:34 ` Ludovic Courtès
17 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2018-06-08 9:34 UTC (permalink / raw)
To: 31755
* Makefile.am (SH_TESTS): Remove tests/guix-register.sh.
* build-aux/pre-inst-env.in (GUIX_REGISTER): Remove.
* gnu/build/install.scm (directives): Remove outdated comment.
* gnu/build/vm.scm (root-partition-initializer): Update comment.
* gnu/packages/package-management.scm (guix-register): Remove.
* guix/config.scm.in (%sbindir, %guix-register-program): Remove.
* guix/scripts/system.scm (install): Adjust docstring.
* guix/self.scm (make-config.scm): Remove #:guix. Do not generate
%sbindir and %guix-register-program.
(specification->package): Remove "guix".
* nix/guix-register/guix-register.cc: Remove.
* nix/local.mk (sbin_PROGRAMS, guix_register_SOURCES)
(guix_register_CPPFLAGS, guix_register_LDFLAGS): Remove.
* tests/guix-register.sh: Remove.
---
.gitignore | 1 -
Makefile.am | 7 -
build-aux/pre-inst-env.in | 6 +-
gnu/build/install.scm | 3 -
gnu/build/vm.scm | 4 +-
gnu/packages/package-management.scm | 36 ----
guix/config.scm.in | 12 +-
guix/scripts/system.scm | 2 +-
guix/self.scm | 21 +--
nix/guix-register/guix-register.cc | 254 ----------------------------
nix/local.mk | 16 --
tests/guix-register.sh | 191 ---------------------
12 files changed, 7 insertions(+), 546 deletions(-)
delete mode 100644 nix/guix-register/guix-register.cc
delete mode 100644 tests/guix-register.sh
diff --git a/.gitignore b/.gitignore
index 38a55a3b5..976be8355 100644
--- a/.gitignore
+++ b/.gitignore
@@ -69,7 +69,6 @@
/etc/guix-publish.conf
/etc/guix-publish.service
/guix-daemon
-/guix-register
/guix/config.scm
/libformat.a
/libstore.a
diff --git a/Makefile.am b/Makefile.am
index d6403c02e..dbfb21b52 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -405,13 +405,6 @@ SH_TESTS = \
tests/guix-graph.sh \
tests/guix-lint.sh
-if BUILD_DAEMON
-
-SH_TESTS += tests/guix-register.sh
-
-endif BUILD_DAEMON
-
-
TESTS = $(SCM_TESTS) $(SH_TESTS)
AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" GUILE_AUTO_COMPILE=0
diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in
index 14315d40d..286a81591 100644
--- a/build-aux/pre-inst-env.in
+++ b/build-aux/pre-inst-env.in
@@ -1,7 +1,7 @@
#!/bin/sh
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2017 Eric Bavier <bavier@cray.com>
#
# This file is part of GNU Guix.
@@ -55,10 +55,6 @@ NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload"
@BUILD_DAEMON_OFFLOAD_FALSE@# No offloading support.
@BUILD_DAEMON_OFFLOAD_FALSE@unset NIX_BUILD_HOOK
-# The 'guix-register' program.
-GUIX_REGISTER="$abs_top_builddir/guix-register"
-export GUIX_REGISTER
-
# The following variables need only be defined when compiling Guix
# modules, but we define them to be on the safe side in case of
# auto-compilation.
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 06ecb3995..5a5e70387 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -110,9 +110,6 @@ STORE."
("/var/guix/gcroots/booted-system" -> "/run/booted-system")
("/var/guix/gcroots/current-system" -> "/run/current-system")
-
- ;; XXX: 'guix-register' creates this symlink with a wrong target, so
- ;; create it upfront to be sure.
("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
(directory "/bin")
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 803cd5996..73d0191de 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -346,7 +346,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
;; Optionally, register the inputs in the image's store.
(when register-closures?
(unless copy-closures?
- ;; XXX: 'guix-register' wants to palpate the things it registers, so
+ ;; XXX: 'register-closure' wants to palpate the things it registers, so
;; bind-mount the store on the target.
(mkdir-p target-store)
(mount (%store-directory) target-store "" MS_BIND))
@@ -365,7 +365,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(display "populating...\n")
(populate-root-file-system system-directory target)
- ;; 'guix-register' resets timestamps and everything, so no need to do it
+ ;; 'register-closure' resets timestamps and everything, so no need to do it
;; once more in that case.
(unless register-closures?
(reset-timestamps target))))
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index b8c14ee5d..8790bd3a2 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -288,42 +288,6 @@ the Nix package manager.")
;; Alias for backward compatibility.
(define-public guix-devel guix)
-(define-public guix-register
- ;; This package is for internal consumption: it allows us to quickly build
- ;; the 'guix-register' program, which is referred to by (guix config).
- ;; TODO: Remove this hack when 'guix-register' has been superseded by Scheme
- ;; code.
- (package
- (inherit guix)
- (properties `((hidden? . #t)))
- (name "guix-register")
-
- ;; Use a minimum set of dependencies.
- (native-inputs
- (fold alist-delete (package-native-inputs guix)
- '("po4a" "graphviz" "help2man")))
- (propagated-inputs
- `(("gnutls" ,gnutls)
- ("guile-git" ,guile-git)))
-
- (arguments
- (substitute-keyword-arguments (package-arguments guix)
- ((#:tests? #f #f)
- #f)
- ((#:phases phases '%standard-phases)
- `(modify-phases ,phases
- (replace 'build
- (lambda _
- (invoke "make" "nix/libstore/schema.sql.hh")
- (invoke "make" "-j" (number->string
- (parallel-job-count))
- "guix-register")))
- (delete 'copy-bootstrap-guile)
- (replace 'install
- (lambda _
- (invoke "make" "install-sbinPROGRAMS")))
- (delete 'wrap-program)))))))
-
(define-public guile2.0-guix
(package
(inherit guix)
diff --git a/guix/config.scm.in b/guix/config.scm.in
index dfe5fe0db..1d84ddf18 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
;;; 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, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;;
;;; This file is part of GNU Guix.
@@ -26,13 +26,11 @@
%storedir
%localstatedir
%sysconfdir
- %sbindir
%store-directory
%state-directory
%store-database-directory
%config-directory
- %guix-register-program
%system
%libgcrypt
@@ -70,9 +68,6 @@
(define %sysconfdir
"@guix_sysconfdir@")
-(define %sbindir
- "@guix_sbindir@")
-
(define %store-directory
(or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
%storedir))
@@ -91,11 +86,6 @@
(or (getenv "GUIX_CONFIGURATION_DIRECTORY")
(string-append %sysconfdir "/guix")))
-(define %guix-register-program
- ;; The 'guix-register' program.
- (or (getenv "GUIX_REGISTER")
- (string-append %sbindir "/guix-register")))
-
(define %system
"@guix_system@")
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 23c45cc5a..af2adc47e 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -198,7 +198,7 @@ TARGET, and register them."
bootcfg bootcfg-file)
"Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
directory TARGET. TARGET must be an absolute directory name since that's what
-'guix-register' expects.
+'register-path' expects.
When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG."
(define (maybe-copy to-copy)
diff --git a/guix/self.scm b/guix/self.scm
index f8b8642bf..2b3e8125f 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -88,8 +88,6 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
("gzip" (ref '(gnu packages compression) 'gzip))
("bzip2" (ref '(gnu packages compression) 'bzip2))
("xz" (ref '(gnu packages compression) 'xz))
- ("guix" (ref '(gnu packages package-management)
- 'guix-register))
("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json))
("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh))
("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git))
@@ -342,7 +340,6 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
#:gzip gzip
#:bzip2 bzip2
#:xz xz
- #:guix guix
#:package-name
%guix-package-name
#:package-version
@@ -387,8 +384,7 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
(define %dependency-variables
;; (guix config) variables corresponding to dependencies.
- '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate
- %sbindir %guix-register-program))
+ '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
(define %persona-variables
;; (guix config) variables that define Guix's persona.
@@ -410,7 +406,7 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
(string<? (symbol->string (car name+value1))
(symbol->string (car name+value2))))))
-(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix
+(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
(package-name "GNU Guix")
(package-version "0")
(bug-report-address "bug-guix@gnu.org")
@@ -426,8 +422,6 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
%guix-version
%guix-bug-report-address
%guix-home-page-url
- %sbindir
- %guix-register-program
%libgcrypt
%libz
%gzip
@@ -445,17 +439,6 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
(define %guix-bug-report-address #$bug-report-address)
(define %guix-home-page-url #$home-page-url)
- (define %sbindir
- ;; This is used to define '%guix-register-program'.
- ;; TODO: Use a derivation that builds nothing but the
- ;; C++ part.
- #+(and guix (file-append guix "/sbin")))
-
- (define %guix-register-program
- (or (getenv "GUIX_REGISTER")
- (and %sbindir
- (string-append %sbindir "/guix-register"))))
-
(define %gzip
#+(and gzip (file-append gzip "/bin/gzip")))
(define %bzip2
diff --git a/nix/guix-register/guix-register.cc b/nix/guix-register/guix-register.cc
deleted file mode 100644
index 16dae62b3..000000000
--- a/nix/guix-register/guix-register.cc
+++ /dev/null
@@ -1,254 +0,0 @@
-/* GNU Guix --- Functional package management for GNU
- Copyright (C) 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
- Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012,
- 2013 Eelco Dolstra <eelco.dolstra@logicblox.com>
-
- 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/>. */
-
-/* This file derives from the implementation of 'nix-store
- --register-validity', by Eelco Dolstra, as found in the Nix package
- manager's src/nix-store/nix-store.cc. */
-
-#include <config.h>
-
-#include <globals.hh>
-#include <local-store.hh>
-
-#include <iostream>
-#include <fstream>
-#include <cstdlib>
-#include <cstdio>
-
-#include <argp.h>
-#include <gcrypt.h>
-
-using namespace nix;
-
-/* Input stream where we read closure descriptions. */
-static std::istream *input = &std::cin;
-
-
-\f
-/* Command-line options. */
-
-const char *argp_program_version =
- "guix-register (" PACKAGE_NAME ") " PACKAGE_VERSION;
-const char *argp_program_bug_address = PACKAGE_BUGREPORT;
-
-static char doc[] =
-"guix-register -- register a closure as valid in a store\
-\v\
-This program is used internally when populating a store with data \
-from an existing store. It updates the new store's database with \
-information about which store files are valid, and what their \
-references are.";
-
-#define GUIX_OPT_STATE_DIRECTORY 1
-#define GUIX_OPT_DEDUPLICATE 2
-
-static const struct argp_option options[] =
- {
- { "prefix", 'p', "DIRECTORY", 0,
- "Open the store that lies under DIRECTORY" },
- { "state-directory", GUIX_OPT_STATE_DIRECTORY, "DIRECTORY", 0,
- "Use DIRECTORY as the state directory of the target store" },
- { "no-deduplication", GUIX_OPT_DEDUPLICATE, 0, 0,
- "Disable automatic deduplication of registered store items" },
- { 0, 0, 0, 0, 0 }
- };
-
-
-/* Prefix of the store being populated. */
-static std::string prefix;
-
-/* Whether to deduplicate the registered store items. */
-static bool deduplication = true;
-
-/* Parse a single option. */
-static error_t
-parse_opt (int key, char *arg, struct argp_state *state)
-{
- switch (key)
- {
- case 'p':
- {
- prefix = canonPath (arg);
- settings.nixStore = prefix + NIX_STORE_DIR;
- settings.nixDataDir = prefix + NIX_DATA_DIR;
- settings.nixLogDir = prefix + NIX_LOG_DIR;
- settings.nixStateDir = prefix + NIX_STATE_DIR;
- settings.nixDBPath = settings.nixStateDir + "/db";
- break;
- }
-
- case GUIX_OPT_STATE_DIRECTORY:
- {
- string state_dir = canonPath (arg);
-
- settings.nixStateDir = state_dir;
- settings.nixDBPath = state_dir + "/db";
- break;
- }
-
- case GUIX_OPT_DEDUPLICATE:
- deduplication = false;
- break;
-
- case ARGP_KEY_ARG:
- {
- std::ifstream *file;
-
- if (state->arg_num >= 2)
- /* Too many arguments. */
- argp_usage (state);
-
- file = new std::ifstream ();
- file->open (arg);
-
- input = file;
- }
- break;
-
- default:
- return (error_t) ARGP_ERR_UNKNOWN;
- }
-
- return (error_t) 0;
-}
-
-/* Argument parsing. */
-static struct argp argp = { options, parse_opt, 0, doc };
-
-\f
-/* Read from INPUT the description of a closure, and register it as valid in
- STORE. The expected format on INPUT is that used by #:references-graphs:
-
- FILE
- DERIVER
- NUMBER-OF-REFERENCES
- REF1
- ...
- REFN
-
- This is really meant as an internal format. */
-static void
-register_validity (LocalStore *store, std::istream &input,
- bool optimize = true,
- bool reregister = true, bool hashGiven = false,
- bool canonicalise = true)
-{
- ValidPathInfos infos;
-
- while (1)
- {
- ValidPathInfo info = decodeValidPathInfo (input, hashGiven);
- if (info.path == "")
- break;
-
- if (!prefix.empty ())
- {
- /* Rewrite the input to refer to the final name, as if we were in a
- chroot under PREFIX. */
- std::string final_prefix (NIX_STORE_DIR "/");
- info.path = final_prefix + baseNameOf (info.path);
- }
-
- /* Keep its real path to canonicalize it and compute its hash. */
- std::string real_path;
- real_path = prefix + "/" + settings.nixStore + "/" + baseNameOf (info.path);
-
- if (!store->isValidPath (info.path) || reregister)
- {
- /* !!! races */
- if (canonicalise)
- canonicalisePathMetaData (real_path, -1);
-
- if (!hashGiven)
- {
- HashResult hash = hashPath (htSHA256, real_path);
- info.hash = hash.first;
- info.narSize = hash.second;
- }
- infos.push_back (info);
- }
- }
-
- store->registerValidPaths (infos);
-
- /* XXX: When PREFIX is non-empty, store->linksDir points to the original
- store's '.links' directory, which means 'optimisePath' would try to link
- to that instead of linking to the target store. Thus, disable
- deduplication in this case. */
- if (optimize)
- {
- /* Make sure deduplication is enabled. */
- settings.autoOptimiseStore = true;
-
- std::string store_dir = settings.nixStore;
-
- /* 'optimisePath' creates temporary links under 'settings.nixStore' and
- this must be the real target store, under PREFIX, to avoid
- cross-device links. Thus, temporarily switch the value of
- 'settings.nixStore'. */
- settings.nixStore = prefix + store_dir;
- for (auto&& i: infos)
- store->optimisePath (prefix + i.path);
- settings.nixStore = store_dir;
- }
-}
-
-\f
-int
-main (int argc, char *argv[])
-{
- /* Initialize libgcrypt, which is indirectly used. */
- if (!gcry_check_version (GCRYPT_VERSION))
- {
- fprintf (stderr, "error: libgcrypt version mismatch\n");
- exit (EXIT_FAILURE);
- }
-
- /* Tell Libgcrypt that initialization has completed, as per the Libgcrypt
- 1.6.0 manual (although this does not appear to be strictly needed.) */
- gcry_control (GCRYCTL_INITIALIZATION_FINISHED, 0);
-
- /* Honor the environment variables, and initialize the settings. */
- settings.processEnvironment ();
-
- try
- {
- argp_parse (&argp, argc, argv, 0, 0, 0);
-
- /* Instantiate the store. This creates any missing directories among
- 'settings.nixStore', 'settings.nixDBPath', etc. */
- LocalStore store;
-
- if (!prefix.empty ())
- /* Under the --prefix tree, the final name of the store will be
- NIX_STORE_DIR. Set it here so that the database uses file names
- prefixed by NIX_STORE_DIR and not PREFIX + NIX_STORE_DIR. */
- settings.nixStore = NIX_STORE_DIR;
-
- register_validity (&store, *input, deduplication);
- }
- catch (std::exception &e)
- {
- fprintf (stderr, "error: %s\n", e.what ());
- return EXIT_FAILURE;
- }
-
- return EXIT_SUCCESS;
-}
diff --git a/nix/local.mk b/nix/local.mk
index b4c6ba61a..140c78df3 100644
--- a/nix/local.mk
+++ b/nix/local.mk
@@ -120,7 +120,6 @@ libstore_a_CXXFLAGS = $(AM_CXXFLAGS) \
$(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS)
bin_PROGRAMS = guix-daemon
-sbin_PROGRAMS = guix-register
guix_daemon_SOURCES = \
%D%/nix-daemon/nix-daemon.cc \
@@ -138,24 +137,9 @@ guix_daemon_LDADD = \
guix_daemon_headers = \
%D%/nix-daemon/shared.hh
-
-guix_register_SOURCES = \
- %D%/guix-register/guix-register.cc
-
-guix_register_CPPFLAGS = \
- $(libutil_a_CPPFLAGS) \
- $(libstore_a_CPPFLAGS) \
- -I$(top_srcdir)/%D%/libstore
-
-# XXX: Should we start using shared libs?
-guix_register_LDADD = \
- libstore.a libutil.a libformat.a -lz \
- $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS)
-
if HAVE_LIBBZ2
guix_daemon_LDADD += -lbz2
-guix_register_LDADD += -lbz2
endif HAVE_LIBBZ2
diff --git a/tests/guix-register.sh b/tests/guix-register.sh
deleted file mode 100644
index 521735b8a..000000000
--- a/tests/guix-register.sh
+++ /dev/null
@@ -1,191 +0,0 @@
-# GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2014, 2015, 2016 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/>.
-
-#
-# Test the 'guix-register' command-line utility.
-#
-
-guix-register --version
-
-new_store="t-register-$$"
-closure="t-register-closure-$$"
-rm -rf "$new_store"
-
-exit_hook=":"
-trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT
-
-#
-# Registering items in the current store---i.e., without '--prefix'.
-#
-
-new_file="$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-guix-register-$$"
-echo "Fake store file to test registration." > "$new_file"
-
-# Register the file with zero references and no deriver.
-guix-register <<EOF
-$new_file
-
-0
-EOF
-
-# Register an idendical file, and make sure it gets deduplicated.
-new_file2="$new_file-duplicate"
-cat "$new_file" > "$new_file2"
-guix-register <<EOF
-$new_file2
-
-0
-EOF
-
-guile -c "
- (exit (= (stat:ino (stat \"$new_file\"))
- (stat:ino (stat \"$new_file2\"))))"
-
-# Make sure both are valid.
-guile -c "
- (use-modules (guix store))
- (define s (open-connection))
- (exit (and (valid-path? s \"$new_file\")
- (valid-path? s \"$new_file2\")
- (null? (references s \"$new_file\"))
- (null? (references s \"$new_file2\"))))"
-
-
-#
-# Registering items in a new store, with '--prefix'.
-#
-
-mkdir -p "$new_store/$storedir"
-new_store_dir="`cd "$new_store/$storedir" ; pwd -P`"
-new_store="`cd "$new_store" ; pwd -P`"
-
-to_copy="`guix build guile-bootstrap`"
-cp -r "$to_copy" "$new_store_dir"
-copied="$new_store_dir/`basename $to_copy`"
-
-# Create a file representing a closure with zero references, and with an empty
-# "deriver" field. Note that we give the file name as it appears in the
-# original store, and 'guix-register' translates it to match the prefix.
-cat >> "$closure" <<EOF
-$to_copy
-
-0
-EOF
-
-# Register it.
-guix-register -p "$new_store" < "$closure"
-
-# Doing it a second time shouldn't hurt.
-guix-register --prefix "$new_store" "$closure"
-
-# Same, but with the database stored in a different place.
-guix-register -p "$new_store" \
- --state-directory "$new_store/chbouib" "$closure"
-
-# Register duplicate files.
-cp "$new_file" "$new_file2" "$new_store_dir"
-guix-register -p "$new_store" <<EOF
-$new_file
-
-0
-EOF
-guix-register -p "$new_store" <<EOF
-$new_file2
-
-0
-EOF
-
-copied_duplicate1="$new_store_dir/`basename $new_file`"
-copied_duplicate2="$new_store_dir/`basename $new_file2`"
-
-# Make sure there is indeed deduplication under $new_store and that there are
-# no cross-store hard links.
-guile -c "
- (exit (and (= (stat:ino (stat \"$copied_duplicate1\"))
- (stat:ino (stat \"$copied_duplicate2\")))
- (not (= (stat:ino (stat \"$new_file\"))
- (stat:ino (stat \"$copied_duplicate1\"))))))"
-
-# Delete them.
-guix gc -d "$new_file" "$new_file2"
-
-# Now make sure this is recognized as valid.
-
-ls -R "$new_store"
-for state_dir in "$localstatedir/guix" "/chbouib"
-do
- NIX_STORE_DIR="$new_store_dir"
- NIX_STATE_DIR="$new_store$state_dir"
- NIX_LOG_DIR="$new_store$state_dir/log/guix"
- NIX_DB_DIR="$new_store$state_dir/db"
- GUIX_DAEMON_SOCKET="$NIX_STATE_DIR/daemon-socket/socket"
-
- export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR NIX_STATE_DIR \
- NIX_LOG_DIR NIX_DB_DIR GUIX_DAEMON_SOCKET
-
- # Check whether we overflow the limitation on local socket name lengths.
- if [ `echo "$GUIX_DAEMON_SOCKET" | wc -c` -ge 108 ]
- then
- # Mark the test as skipped even though we already did some work so
- # that the remainder is not silently skipped.
- exit 77
- fi
-
- guix-daemon --disable-chroot &
- subdaemon_pid=$!
- exit_hook="kill $subdaemon_pid"
-
- final_name="$storedir/`basename $to_copy`"
-
- # At this point the copy in $new_store must be valid, and unreferenced.
- # The database under $NIX_DB_DIR uses the $final_name, but we can't use
- # that name in a 'valid-path?' query because 'assertStorePath' would kill
- # us because of the wrong prefix. So we just list dead paths instead.
- guile -c "
- (use-modules (guix store) (srfi srfi-1) (srfi srfi-34))
-
- (define s
- (let loop ((i 5))
- (guard (c ((nix-connection-error? c)
- (if (<= i 0)
- (raise c)
- (begin
- (display \"waiting for daemon socket...\")
- (newline)
- (sleep 1)
- (loop (- i 1))))))
- (open-connection \"$GUIX_DAEMON_SOCKET\"))))
-
- (exit (lset= string=?
- (pk 1 (list \"$copied\" \"$copied_duplicate1\"
- \"$copied_duplicate2\"))
- (pk 2 (dead-paths s))))"
-
- # Kill the daemon so we can access the database below (otherwise we may
- # get "database is locked" errors.)
- kill $subdaemon_pid
- exit_hook=":"
- while kill -0 $subdaemon_pid ; do sleep 0.5 ; done
-
- # When 'sqlite3' is available, check the name in the database.
- if type -P sqlite3
- then
- echo "select * from ValidPaths where path=\"$final_name\";" | \
- sqlite3 "$NIX_DB_DIR/db.sqlite"
- fi
-done
--
2.17.1
^ permalink raw reply related [flat|nested] 22+ messages in thread