aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/r.scm4
-rw-r--r--guix/build/store-copy.scm121
-rw-r--r--guix/config.scm.in12
-rw-r--r--guix/import/utils.scm2
-rw-r--r--guix/nar.scm3
-rw-r--r--guix/scripts/offload.scm14
-rw-r--r--guix/scripts/pack.scm243
-rw-r--r--guix/scripts/pull.scm149
-rwxr-xr-xguix/scripts/substitute.scm4
-rw-r--r--guix/scripts/system.scm3
-rw-r--r--guix/self.scm88
-rw-r--r--guix/store.scm29
-rw-r--r--guix/store/database.scm235
-rw-r--r--guix/store/deduplication.scm13
-rw-r--r--guix/store/schema.sql44
-rw-r--r--guix/ui.scm7
-rw-r--r--guix/utils.scm6
17 files changed, 638 insertions, 339 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
index d20f66e1a9..d5f897932f 100644
--- a/guix/build-system/r.scm
+++ b/guix/build-system/r.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -74,7 +74,7 @@ release corresponding to NAME and VERSION."
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
- '(#:source #:target #:inputs #:native-inputs))
+ '(#:source #:target #:r #:inputs #:native-inputs))
(and (not target) ;XXX: no cross-compilation
(bag
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index fe2eb6f69a..2d9590d16f 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,22 @@
(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
+ store-info-item
+ store-info-deriver
+ store-info-references
+
+ read-reference-graph
+
closure-size
populate-store))
@@ -34,19 +46,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 +159,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 +176,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/config.scm.in b/guix/config.scm.in
index aeea81bd3f..4490112e07 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/import/utils.scm b/guix/import/utils.scm
index df85904c6f..0dc8fd5857 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -420,7 +420,7 @@ dependencies."
;; generator: update the queue
(lambda (state)
(receive (package . dependencies)
- (repo->guix-package package-name repo)
+ (repo->guix-package (next state) repo)
(if package
(update state (filter (cut unknown? <>
(cons (next state)
diff --git a/guix/nar.scm b/guix/nar.scm
index 9b4c608238..3556de1379 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/offload.scm b/guix/scripts/offload.scm
index fb61d7c059..ee5857e16b 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -124,7 +124,15 @@ determined."
(save-module-excursion
(lambda ()
(set-current-module %user-module)
- (primitive-load file))))
+ (match (primitive-load file)
+ (((? build-machine? machines) ...)
+ machines)
+ (_
+ ;; Instead of crashing, assume the empty list.
+ (warning (G_ "'~a' did not return a list of build machines; \
+ignoring it~%")
+ file)
+ '())))))
(lambda args
(match args
(('system-error . rest)
@@ -605,8 +613,8 @@ If TIMEOUT is #f, simply evaluate EXP..."
(leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%")
name x))))
(lambda (key . args)
- (leave (G_ "remove evaluation on '~a' failed:~{ ~s~}~%")
- args))))
+ (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%")
+ name args))))
(define %random-state
(delay
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 76729d8e10..ed876b2592 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 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))
+ (define not-config?
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix _ ...) #t)
+ (('gnu _ ...) #t)
+ (_ #f)))
- (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 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")))
-
- ;; We need Guix here for 'guix-register'.
- (setenv "PATH"
- (string-append #$(if localstatedir?
- (file-append guix "/sbin:")
- "")
- #$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?)
-
- ;; 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"
-
- ;; 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")
- '())
-
- (string-append "." (%store-directory))
-
- (delete-duplicates
- (filter-map (match-lambda
- (('directory directory)
- (string-append "." directory))
- ((source '-> _)
- (string-append "." source))
- (_ #f))
- directives)))))))))
+ (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 `(((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 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))
+
+ ;; 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")))
+
+ ;; 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?
+ #:schema #$schema)
+
+ ;; 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"
+
+ ;; 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")
+ '())
+
+ (string-append "." (%store-directory))
+
+ (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))
@@ -251,8 +272,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 +374,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/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 499de0ec45..7202e3cc16 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -45,6 +45,7 @@
#:use-module ((gnu packages certs) #:select (le-certs))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (guix-pull))
@@ -110,6 +111,9 @@ Download and deploy the latest version of Guix.\n"))
(display (G_ "
--branch=BRANCH download the tip of the specified BRANCH"))
(display (G_ "
+ -l, --list-generations[=PATTERN]
+ list generations matching PATTERN"))
+ (display (G_ "
--bootstrap use the bootstrap Guile to build the new Guix"))
(newline)
(show-build-options-help)
@@ -125,6 +129,10 @@ Download and deploy the latest version of Guix.\n"))
(cons* (option '("verbose") #f #f
(lambda (opt name arg result)
(alist-cons 'verbose? #t result)))
+ (option '(#\l "list-generations") #f #t
+ (lambda (opt name arg result)
+ (cons `(query list-generations ,(or arg ""))
+ result)))
(option '("url") #t #f
(lambda (opt name arg result)
(alist-cons 'repository-url arg
@@ -274,6 +282,66 @@ certificates~%"))
(report-git-error err))))
+;;;
+;;; Queries.
+;;;
+
+(define (display-profile-content profile number)
+ "Display the packages in PROFILE, generation NUMBER, in a human-readable
+way and displaying details about the channel's source code."
+ (for-each (lambda (entry)
+ (format #t " ~a ~a~%"
+ (manifest-entry-name entry)
+ (manifest-entry-version entry))
+ (match (assq 'source (manifest-entry-properties entry))
+ (('source ('repository ('version 0)
+ ('url url)
+ ('branch branch)
+ ('commit commit)
+ _ ...))
+ (format #t (G_ " repository URL: ~a~%") url)
+ (when branch
+ (format #t (G_ " branch: ~a~%") branch))
+ (format #t (G_ " commit: ~a~%") commit))
+ (_ #f)))
+
+ ;; Show most recently installed packages last.
+ (reverse
+ (manifest-entries
+ (profile-manifest (generation-file-name profile number))))))
+
+(define (process-query opts)
+ "Process any query specified by OPTS."
+ (define profile
+ (string-append (config-directory) "/current"))
+
+ (match (assoc-ref opts 'query)
+ (('list-generations pattern)
+ (define (list-generation display-function number)
+ (unless (zero? number)
+ (display-generation profile number)
+ (display-function profile number)
+ (newline)))
+
+ (leave-on-EPIPE
+ (cond ((not (file-exists? profile)) ; XXX: race condition
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((string-null? pattern)
+ (for-each (lambda (generation)
+ (list-generation display-profile-content generation))
+ (profile-generations profile)))
+ ((matching-generations pattern profile)
+ =>
+ (match-lambda
+ (()
+ (exit 1))
+ ((numbers ...)
+ (for-each (lambda (generation)
+ (list-generation display-profile-content generation))
+ numbers)))))))))
+
+
(define (guix-pull . args)
(define (use-le-certs? url)
(string-prefix? "https://git.savannah.gnu.org/" url))
@@ -287,43 +355,48 @@ certificates~%"))
(cache (string-append (cache-directory) "/pull")))
(ensure-guile-git!)
- (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful
- (with-store store
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
- (set-build-options-from-command-line store opts)
-
- ;; For reproducibility, always refer to the LE certificates when we
- ;; know we're talking to Savannah.
- (when (use-le-certs? url)
- (honor-lets-encrypt-certificates! store))
-
- (format (current-error-port)
- (G_ "Updating from Git repository at '~a'...~%")
- url)
-
- (let-values (((checkout commit)
- (latest-repository-commit store url
- #:ref ref
- #:cache-directory cache)))
-
- (format (current-error-port)
- (G_ "Building from Git commit ~a...~%")
- commit)
- (parameterize ((%guile-for-build
- (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- (build-and-install checkout (config-directory)
- #:url url
- #:branch (match ref
- (('branch . branch)
- branch)
- (_ #f))
- #:commit commit
- #:verbose?
- (assoc-ref opts 'verbose?))))))))))))
+ (cond ((assoc-ref opts 'query)
+ (process-query opts))
+ ((assoc-ref opts 'dry-run?)
+ #t) ;XXX: not very useful
+ (else
+ (with-store store
+ (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (set-build-options-from-command-line store opts)
+
+ ;; For reproducibility, always refer to the LE certificates
+ ;; when we know we're talking to Savannah.
+ (when (use-le-certs? url)
+ (honor-lets-encrypt-certificates! store))
+
+ (format (current-error-port)
+ (G_ "Updating from Git repository at '~a'...~%")
+ url)
+
+ (let-values (((checkout commit)
+ (latest-repository-commit store url
+ #:ref ref
+ #:cache-directory
+ cache)))
+
+ (format (current-error-port)
+ (G_ "Building from Git commit ~a...~%")
+ commit)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (run-with-store store
+ (build-and-install checkout (config-directory)
+ #:url url
+ #:branch (match ref
+ (('branch . branch)
+ branch)
+ (_ #f))
+ #:commit commit
+ #:verbose?
+ (assoc-ref opts 'verbose?)))))))))))))
;;; pull.scm ends here
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 8e1119fb49..d0beacc8ea 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -613,10 +613,10 @@ if file doesn't exist, and the narinfo otherwise."
(let ((done 0)
(total (length paths)))
(lambda ()
- (display #\cr (current-error-port))
+ (display "\r\x1b[K" (current-error-port)) ;erase current line
(force-output (current-error-port))
(format (current-error-port)
- (G_ "updating list of substitutes from '~a'... ~5,1f%")
+ (G_ "updating substitutes from '~a'... ~5,1f%")
url (* 100. (/ done total)))
(set! done (+ 1 done)))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 14be8ff8cf..727f1ac55f 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)
@@ -197,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 e71e086cdc..5a10f72012 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -89,8 +89,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,8 @@ DOMAIN, a gettext domain."
(computed-file "guix-manual" build))
-(define* (guix-command modules #:key source (dependencies '())
+(define* (guix-command modules #:optional compiled-modules
+ #:key source (dependencies '())
(guile-version (effective-version)))
"Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
load path."
@@ -366,7 +365,8 @@ load path."
(set! %load-path (cons #$modules %load-path))
(set! %load-compiled-path
- (cons #$modules %load-compiled-path))
+ (cons (or #$compiled-modules #$modules)
+ %load-compiled-path))
(let ((guix-main (module-ref (resolve-interface '(guix ui))
'guix-main)))
@@ -387,14 +387,16 @@ load path."
(define* (whole-package name modules dependencies
#:key
(guile-version (effective-version))
- info
+ compiled-modules
+ info daemon
(command (guix-command modules
#:dependencies dependencies
#:guile-version guile-version)))
"Return the whole Guix package NAME that uses MODULES, a derivation of all
the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
-'guix' program to use; INFO is the Info manual."
- ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'.
+'guix' program to use; INFO is the Info manual. When COMPILED-MODULES is
+true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are
+assumed to be part of MODULES."
(computed-file name
(with-imported-modules '((guix build utils))
#~(begin
@@ -403,6 +405,10 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
(symlink #$command
(string-append #$output "/bin/guix"))
+ (when #$daemon
+ (symlink (string-append #$daemon "/bin/guix-daemon")
+ (string-append #$output "/bin/guix-daemon")))
+
(let ((modules (string-append #$output
"/share/guile/site/"
(effective-version)))
@@ -412,7 +418,15 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
(when info
(symlink #$info
(string-append #$output
- "/share/info"))))))))
+ "/share/info"))))
+
+ ;; Object files.
+ (when #$compiled-modules
+ (let ((modules (string-append #$output "/lib/guile/"
+ (effective-version)
+ "/site-ccache")))
+ (mkdir-p (dirname modules))
+ (symlink #$compiled-modules modules)))))))
(define* (compiled-guix source #:key (version %guix-version)
(pull-version 1)
@@ -482,7 +496,9 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
;; but we don't need to compile it; not compiling it allows
;; us to avoid an extra dependency on guile-gdbm-ffi.
#:extra-files
- `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")))
+ `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))
+ ("guix/store/schema.sql"
+ ,(local-file "../guix/store/schema.sql")))
#:guile-for-build guile-for-build))
@@ -563,7 +579,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
#:gzip gzip
#:bzip2 bzip2
#:xz xz
- #:guix guix
#:package-name
%guix-package-name
#:package-version
@@ -574,11 +589,9 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
%guix-home-page-url)))
#:guile-for-build guile-for-build))
- (define built-modules
+ (define (built-modules node-subset)
(directory-union (string-append name "-modules")
- (append-map (lambda (node)
- (list (node-source node)
- (node-compiled node)))
+ (append-map node-subset
;; Note: *CONFIG* comes first so that it
;; overrides the (guix config) module that
@@ -606,17 +619,32 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
;; Version 1 is when we return the full package.
(cond ((= 1 pull-version)
;; The whole package, with a standard file hierarchy.
- (let ((command (guix-command built-modules
- #:source source
- #:dependencies dependencies
- #:guile-version guile-version)))
- (whole-package name built-modules dependencies
+ (let* ((modules (built-modules (compose list node-source)))
+ (compiled (built-modules (compose list node-compiled)))
+ (command (guix-command modules compiled
+ #:source source
+ #:dependencies dependencies
+ #:guile-version guile-version)))
+ (whole-package name modules dependencies
+ #:compiled-modules compiled
#:command command
+
+ ;; Include 'guix-daemon'. XXX: Here we inject an
+ ;; older snapshot of guix-daemon, but that's a good
+ ;; enough approximation for now.
+ #:daemon (module-ref (resolve-interface
+ '(gnu packages
+ package-management))
+ 'guix-daemon)
+
#:info (info-manual source)
#:guile-version guile-version)))
((= 0 pull-version)
- ;; Legacy 'guix pull': just return the compiled modules.
- built-modules)
+ ;; Legacy 'guix pull': return the .scm and .go files as one
+ ;; directory.
+ (built-modules (lambda (node)
+ (list (node-source node)
+ (node-compiled node)))))
(else
;; Unsupported 'guix pull' version.
#f)))
@@ -628,8 +656,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
(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.
@@ -651,7 +678,7 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
(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")
@@ -667,8 +694,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
%guix-version
%guix-bug-report-address
%guix-home-page-url
- %sbindir
- %guix-register-program
%libgcrypt
%libz
%gzip
@@ -686,17 +711,6 @@ the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
(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/guix/store.scm b/guix/store.scm
index 6742611c6f..773d53e82b 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))))))
-
;;;
;;; Store monad.
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 3623c0e7a0..05b2ba6c3f 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -24,30 +24,76 @@
#:use-module (guix store deduplication)
#:use-module (guix base16)
#:use-module (guix build syscalls)
+ #:use-module ((guix build utils)
+ #:select (mkdir-p executable-file?))
+ #:use-module (guix build store-copy)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 match)
- #:export (sqlite-register
+ #:use-module (system foreign)
+ #:export (sql-schema
+ with-database
+ sqlite-register
register-path
+ register-items
+ %epoch
reset-timestamps))
;;; Code for working with the store database directly.
+(define sql-schema
+ ;; Name of the file containing the SQL scheme or #f.
+ (make-parameter #f))
-(define-syntax-rule (with-database file db exp ...)
- "Open DB from FILE and close it when the dynamic extent of EXP... is left."
- (let ((db (sqlite-open file)))
+(define sqlite-exec
+ ;; XXX: This is was missing from guile-sqlite3 until
+ ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
+ (let ((exec (pointer->procedure
+ int
+ (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))
+ '(* * * * *))))
+ (lambda (db text)
+ (let ((ret (exec ((@@ (sqlite3) db-pointer) db)
+ (string->pointer text)
+ %null-pointer %null-pointer %null-pointer)))
+ (unless (zero? ret)
+ ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret))))))
+
+(define (initialize-database db)
+ "Initializing DB, an empty database, by creating all the tables and indexes
+as specified by SQL-SCHEMA."
+ (define schema
+ (or (sql-schema)
+ (search-path %load-path "guix/store/schema.sql")))
+
+ (sqlite-exec db (call-with-input-file schema get-string-all)))
+
+(define (call-with-database file proc)
+ "Pass PROC a database record corresponding to FILE. If FILE doesn't exist,
+create it and initialize it as a new database."
+ (let ((new? (not (file-exists? file)))
+ (db (sqlite-open file)))
(dynamic-wind noop
(lambda ()
- exp ...)
+ (when new?
+ (initialize-database db))
+ (proc db))
(lambda ()
(sqlite-close db)))))
+(define-syntax-rule (with-database file db exp ...)
+ "Open DB from FILE and close it when the dynamic extent of EXP... is left.
+If FILE doesn't exist, create it and initialize it as a new database."
+ (call-with-database file (lambda (db) exp ...)))
+
(define (last-insert-row-id db)
;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
;; Work around that.
(let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();"
- #:cache? #t))
+ #:cache? #t))
(result (sqlite-fold cons '() stmt)))
(sqlite-finalize stmt)
(match result
@@ -85,7 +131,7 @@ of course. Returns the row id of the row that was modified or inserted."
(if id
(let ((stmt (sqlite-prepare db update-sql #:cache? #t)))
(sqlite-bind-arguments stmt #:id id
- #:path path #:deriver deriver
+ #:deriver deriver
#:hash hash #:size nar-size #:time time)
(sqlite-fold cons '() stmt)
(sqlite-finalize stmt)
@@ -99,13 +145,11 @@ of course. Returns the row id of the row that was modified or inserted."
(last-insert-row-id db)))))
(define add-reference-sql
- "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id
-FROM ValidPaths WHERE path = :reference")
+ "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);")
(define (add-references db referrer references)
"REFERRER is the id of the referring store item, REFERENCES is a list
-containing store items being referred to. Note that all of the store items in
-REFERENCES must already be registered."
+ids of items referred to."
(let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t)))
(for-each (lambda (reference)
(sqlite-reset stmt)
@@ -116,37 +160,41 @@ REFERENCES must already be registered."
(last-insert-row-id db))
references)))
-;; XXX figure out caching of statement and database objects... later
-(define* (sqlite-register #:key db-file path (references '())
- deriver hash nar-size)
- "Registers this stuff in a database specified by DB-FILE. PATH is the string
-path of some store item, REFERENCES is a list of string paths which the store
-item PATH refers to (they need to be already registered!), DERIVER is a string
-path of the derivation that created the store item PATH, HASH is the
-base16-encoded sha256 hash of the store item denoted by PATH (prefixed with
-\"sha256:\") after being converted to nar form, and nar-size is the size in
-bytes of the store item denoted by PATH after being converted to nar form."
- (with-database db-file db
- (let ((id (update-or-insert db #:path path
- #:deriver deriver
- #:hash hash
- #:nar-size nar-size
- #:time (time-second (current-time time-utc)))))
- (add-references db id references))))
+(define* (sqlite-register db #:key path (references '())
+ deriver hash nar-size time)
+ "Registers this stuff in DB. PATH is the store item to register and
+REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv'
+that produced PATH, HASH is the base16-encoded Nix sha256 hash of
+PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after
+being converted to nar form. TIME is the registration time to be recorded in
+the database or #f, meaning \"right now\".
+
+Every store item in REFERENCES must already be registered."
+ (let ((id (update-or-insert db #:path path
+ #:deriver deriver
+ #:hash hash
+ #:nar-size nar-size
+ #:time (time-second
+ (or time
+ (current-time time-utc))))))
+ ;; Call 'path-id' on each of REFERENCES. This ensures we get a
+ ;; "non-NULL constraint" failure if one of REFERENCES is unregistered.
+ (add-references db id
+ (map (cut path-id db <>) references))))
;;;
;;; High-level interface.
;;;
-;; TODO: Factorize with that in (gnu build install).
(define (reset-timestamps file)
"Reset the modification time on FILE and on all the files it contains, if
-it's a directory."
+it's a directory. While at it, canonicalize file permissions."
(let loop ((file file)
(type (stat:type (lstat file))))
(case type
((directory)
+ (chmod file #o555)
(utime file 0 0 0 0)
(let ((parent file))
(for-each (match-lambda
@@ -165,24 +213,14 @@ it's a directory."
;; symlinks.
#f)
(else
+ (chmod file (if (executable-file? file) #o555 #o444))
(utime file 0 0 0 0)))))
-;; TODO: make this canonicalize store items that are registered. This involves
-;; setting permissions and timestamps, I think. Also, run a "deduplication
-;; pass", whatever that involves. Also, handle databases not existing yet
-;; (what should the default behavior be? Figuring out how the C++ stuff
-;; currently does it sounds like a lot of grepping for global
-;; variables...). Also, return #t on success like the documentation says we
-;; should.
-
(define* (register-path path
#:key (references '()) deriver prefix
- state-directory (deduplicate? #t))
- ;; Priority for options: first what is given, then environment variables,
- ;; then defaults. %state-directory, %store-directory, and
- ;; %store-database-directory already handle the "environment variables /
- ;; defaults" question, so we only need to choose between what is given and
- ;; those.
+ state-directory (deduplicate? #t)
+ (reset-timestamps? #t)
+ (schema (sql-schema)))
"Register PATH as a valid store file, with REFERENCES as its list of
references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
given, it must be the name of the directory containing the new store to
@@ -192,43 +230,76 @@ Return #t on success.
Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook."
- (let* ((db-dir (cond
- (state-directory
- (string-append state-directory "/db"))
- (prefix
- ;; If prefix is specified, the value of NIX_STATE_DIR
- ;; (which affects %state-directory) isn't supposed to
- ;; affect db-dir, only the compile-time-customized
- ;; default should.
- (string-append prefix %localstatedir "/guix/db"))
- (else
- %store-database-directory)))
- (store-dir (if prefix
- ;; same situation as above
- (string-append prefix %storedir)
- %store-directory))
- (to-register (if prefix
- (string-append %storedir "/" (basename path))
- ;; note: we assume here that if path is, for
- ;; example, /foo/bar/gnu/store/thing.txt and prefix
- ;; isn't given, then an environment variable has
- ;; been used to change the store directory to
- ;; /foo/bar/gnu/store, since otherwise real-path
- ;; would end up being /gnu/store/thing.txt, which is
- ;; probably not the right file in this case.
- path))
- (real-path (string-append store-dir "/" (basename path))))
- (let-values (((hash nar-size)
- (nar-sha256 real-path)))
- (reset-timestamps real-path)
- (sqlite-register
- #:db-file (string-append db-dir "/db.sqlite")
- #:path to-register
- #:references references
- #:deriver deriver
- #:hash (string-append "sha256:"
- (bytevector->base16-string hash))
- #:nar-size nar-size)
+ (register-items (list (store-info path deriver references))
+ #:prefix prefix #:state-directory state-directory
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:schema schema))
+(define %epoch
+ ;; When it all began.
+ (make-time time-utc 0 1))
+
+(define* (register-items items
+ #:key prefix state-directory
+ (deduplicate? #t)
+ (reset-timestamps? #t)
+ registration-time
+ (schema (sql-schema)))
+ "Register all of ITEMS, a list of <store-info> records as returned by
+'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS
+must be in topological order (with leaves first.) If the database is
+initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the
+registration time to be recorded in the database; #f means \"now\"."
+
+ ;; Priority for options: first what is given, then environment variables,
+ ;; then defaults. %state-directory, %store-directory, and
+ ;; %store-database-directory already handle the "environment variables /
+ ;; defaults" question, so we only need to choose between what is given and
+ ;; those.
+
+ (define db-dir
+ (cond (state-directory
+ (string-append state-directory "/db"))
+ (prefix
+ (string-append prefix %localstatedir "/guix/db"))
+ (else
+ %store-database-directory)))
+
+ (define store-dir
+ (if prefix
+ (string-append prefix %storedir)
+ %store-directory))
+
+ (define (register db item)
+ (define to-register
+ (if prefix
+ (string-append %storedir "/" (basename (store-info-item item)))
+ ;; note: we assume here that if path is, for example,
+ ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an
+ ;; environment variable has been used to change the store directory
+ ;; to /foo/bar/gnu/store, since otherwise real-path would end up
+ ;; being /gnu/store/thing.txt, which is probably not the right file
+ ;; in this case.
+ (store-info-item item)))
+
+ (define real-file-name
+ (string-append store-dir "/" (basename (store-info-item item))))
+
+ (let-values (((hash nar-size) (nar-sha256 real-file-name)))
+ (when reset-timestamps?
+ (reset-timestamps real-file-name))
+ (sqlite-register db #:path to-register
+ #:references (store-info-references item)
+ #:deriver (store-info-deriver item)
+ #:hash (string-append "sha256:"
+ (bytevector->base16-string hash))
+ #:nar-size nar-size
+ #:time registration-time)
(when deduplicate?
- (deduplicate real-path hash #:store store-dir)))))
+ (deduplicate real-file-name hash #:store store-dir))))
+
+ (mkdir-p db-dir)
+ (parameterize ((sql-schema schema))
+ (with-database (string-append db-dir "/db.sqlite") db
+ (for-each (cut register db <>) items))))
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 4b4ac01f64..d3139eb904 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/guix/store/schema.sql b/guix/store/schema.sql
new file mode 100644
index 0000000000..c1b4a689af
--- /dev/null
+++ b/guix/store/schema.sql
@@ -0,0 +1,44 @@
+create table if not exists ValidPaths (
+ id integer primary key autoincrement not null,
+ path text unique not null,
+ hash text not null,
+ registrationTime integer not null,
+ deriver text,
+ narSize integer
+);
+
+create table if not exists Refs (
+ referrer integer not null,
+ reference integer not null,
+ primary key (referrer, reference),
+ foreign key (referrer) references ValidPaths(id) on delete cascade,
+ foreign key (reference) references ValidPaths(id) on delete restrict
+);
+
+create index if not exists IndexReferrer on Refs(referrer);
+create index if not exists IndexReference on Refs(reference);
+
+-- Paths can refer to themselves, causing a tuple (N, N) in the Refs
+-- table. This causes a deletion of the corresponding row in
+-- ValidPaths to cause a foreign key constraint violation (due to `on
+-- delete restrict' on the `reference' column). Therefore, explicitly
+-- get rid of self-references.
+create trigger if not exists DeleteSelfRefs before delete on ValidPaths
+ begin
+ delete from Refs where referrer = old.id and reference = old.id;
+ end;
+
+create table if not exists DerivationOutputs (
+ drv integer not null,
+ id text not null, -- symbolic output id, usually "out"
+ path text not null,
+ primary key (drv, id),
+ foreign key (drv) references ValidPaths(id) on delete cascade
+);
+
+create index if not exists IndexDerivationOutputs on DerivationOutputs(path);
+
+create table if not exists FailedPaths (
+ path text primary key not null,
+ time integer not null
+);
diff --git a/guix/ui.scm b/guix/ui.scm
index 99f66b0fdc..31830ee850 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1391,7 +1391,12 @@ DURATION-RELATION with the current time."
(date->string
(time-utc->date
(generation-time profile number))
- "~b ~d ~Y ~T")))
+ ;; TRANSLATORS: This is a format-string for date->string.
+ ;; Please choose a format that corresponds to the
+ ;; usual way of presenting dates in your locale.
+ ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html
+ ;; for details.
+ (G_ "~b ~d ~Y ~T"))))
(current (generation-number profile)))
(if (= number current)
;; TRANSLATORS: The word "current" here is an adjective for
diff --git a/guix/utils.scm b/guix/utils.scm
index e9efea5866..a5de9605e7 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -7,6 +7,7 @@
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -77,6 +78,7 @@
package-name->name+version
target-mingw?
target-arm32?
+ target-64bit?
version-compare
version>?
version>=?
@@ -474,6 +476,10 @@ a character other than '@'."
(define (target-arm32?)
(string-prefix? "arm" (or (%current-target-system) (%current-system))))
+(define (target-64bit?)
+ (let ((system (or (%current-target-system) (%current-system))))
+ (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))))
+
(define version-compare
(let ((strverscmp
(let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-30 21:44:25 +0000