diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/store-copy.scm | 23 | ||||
| -rw-r--r-- | guix/channels.scm | 16 | ||||
| -rw-r--r-- | guix/git-download.scm | 15 | ||||
| -rw-r--r-- | guix/gnupg.scm | 2 | ||||
| -rw-r--r-- | guix/inferior.scm | 366 | ||||
| -rw-r--r-- | guix/profiles.scm | 27 | ||||
| -rw-r--r-- | guix/progress.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 20 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 4 | ||||
| -rw-r--r-- | guix/serialization.scm | 3 | ||||
| -rw-r--r-- | guix/store/database.scm | 44 |
11 files changed, 466 insertions, 58 deletions
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 2d9590d16f..64ade7885c 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -19,6 +19,7 @@ (define-module (guix build store-copy) #:use-module (guix build utils) #:use-module (guix sets) + #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -167,7 +168,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) -(define* (populate-store reference-graphs target) +(define* (populate-store reference-graphs target + #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." (define store @@ -183,9 +185,20 @@ REFERENCE-GRAPHS, a list of reference-graph files." (mkdir-p store) (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append target thing))) - (things-to-copy))) + + (let* ((things (things-to-copy)) + (len (length things)) + (progress (progress-reporter/bar len + (format #f "copying ~a store items" + len) + log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing) + #:log (%make-void-port "w")) + (report)) + things))))) ;;; store-copy.scm ends here diff --git a/guix/channels.scm b/guix/channels.scm index 2e7bffae9f..82389eb583 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -47,9 +47,9 @@ channel-instance-checkout latest-channel-instances - channel-instance-derivations latest-channel-derivation - channel-instances->manifest)) + channel-instances->manifest + channel-instances->derivation)) ;;; Commentary: ;;; @@ -294,13 +294,17 @@ channel instances." (zip instances derivations)))) (return (manifest entries)))) +(define (channel-instances->derivation instances) + "Return the derivation of the profile containing INSTANCES, a list of +channel instances." + (mlet %store-monad ((manifest (channel-instances->manifest instances))) + (profile-derivation manifest))) + (define latest-channel-instances* (store-lift latest-channel-instances)) (define* (latest-channel-derivation #:optional (channels %default-channels)) "Return as a monadic value the derivation that builds the profile for the latest instances of CHANNELS." - (mlet* %store-monad ((instances ((store-lift latest-channel-instances) - channels)) - (manifest (channel-instances->manifest instances))) - (profile-derivation manifest))) + (mlet %store-monad ((instances (latest-channel-instances* channels))) + (channel-instances->derivation instances))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 24cf11be5e..fa94fad8f8 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -156,22 +156,23 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." The result is similar to that of the 'git ls-files' command, except that it also includes directories, not just regular files. The returned file names are relative to DIRECTORY, which is not necessarily the root of the checkout." - (let* ((directory (canonicalize-path directory)) + (let* (;; 'repository-working-directory' always returns a trailing "/", + ;; so add one here to ease the comparisons below. + (directory (string-append (canonicalize-path directory) "/")) (dot-git (repository-discover directory)) - (top (dirname dot-git)) (repository (repository-open dot-git)) + ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0. + (workdir ((@@ (git repository) repository-working-directory) + repository)) (head (repository-head repository)) (oid (reference-target head)) (commit (commit-lookup repository oid)) (tree (commit-tree commit)) (files (tree-list tree))) (repository-close! repository) - (if (string=? top directory) + (if (string=? workdir directory) files - (let ((relative (string-append - (string-drop directory - (+ 1 (string-length top))) - "/"))) + (let ((relative (string-drop directory (string-length workdir)))) (filter-map (lambda (file) (and (string-prefix? relative file) (string-drop file (string-length relative)))) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index b30ce461b4..40feb44561 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -57,7 +57,7 @@ (define %openpgp-key-server ;; The default key server. Note that keys.gnupg.net appears to be ;; unreliable. - (make-parameter "pgp.mit.edu")) + (make-parameter "pool.sks-keyservers.net")) (define* (gnupg-verify sig file #:optional (keyring (current-keyring))) diff --git a/guix/inferior.scm b/guix/inferior.scm index af37233a03..1dbb9e1699 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,24 +19,68 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module ((guix utils) #:select (source-properties->location)) + #:use-module ((guix utils) + #:select (%current-system + source-properties->location + call-with-temporary-directory + version>? version-prefix? + cache-directory)) + #:use-module ((guix store) + #:select (nix-server-socket + nix-server-major-version + nix-server-minor-version + store-lift)) + #:use-module ((guix derivations) + #:select (read-derivation-from-file)) + #:use-module (guix gexp) + #:use-module (guix search-paths) + #:use-module (guix profiles) + #:use-module (guix channels) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix base32) + #:use-module (gcrypt hash) + #:autoload (guix cache) (maybe-remove-expired-cache-entries) + #:autoload (guix ui) (show-what-to-build*) + #:autoload (guix build utils) (mkdir-p) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 popen) + #:use-module (ice-9 vlist) + #:use-module (ice-9 binary-ports) + #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior close-inferior inferior-eval inferior-object? + inferior-packages + lookup-inferior-packages + inferior-package? inferior-package-name inferior-package-version - - inferior-packages inferior-package-synopsis inferior-package-description inferior-package-home-page - inferior-package-location)) + inferior-package-location + inferior-package-inputs + inferior-package-native-inputs + inferior-package-propagated-inputs + inferior-package-transitive-propagated-inputs + inferior-package-native-search-paths + inferior-package-transitive-native-search-paths + inferior-package-search-paths + inferior-package-derivation + + inferior-package->manifest-entry + + %inferior-cache-directory + inferior-for-channels)) ;;; Commentary: ;;; @@ -48,11 +92,13 @@ ;; Inferior Guix process. (define-record-type <inferior> - (inferior pid socket version) + (inferior pid socket version packages table) inferior? (pid inferior-pid) (socket inferior-socket) - (version inferior-version)) ;REPL protocol version + (version inferior-version) ;REPL protocol version + (packages inferior-package-promise) ;promise of inferior packages + (table inferior-package-table)) ;promise of vhash (define (inferior-pipe directory command) "Return an input/output pipe on the Guix instance in DIRECTORY. This runs @@ -96,9 +142,12 @@ equivalent. Return #f if the inferior could not be launched." (match (read pipe) (('repl-version 0 rest ...) - (let ((result (inferior 'pipe pipe (cons 0 rest)))) + (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (delay (%inferior-packages result)) + (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) + (inferior-eval '(use-modules (ice-9 match)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -123,8 +172,7 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! <inferior-object> write-inferior-object) -(define (inferior-eval exp inferior) - "Evaluate EXP in INFERIOR." +(define (read-inferior-response inferior) (define sexp->object (match-lambda (('value value) @@ -132,14 +180,21 @@ equivalent. Return #f if the inferior could not be launched." (('non-self-quoting address string) (inferior-object address string)))) - (write exp (inferior-socket inferior)) - (newline (inferior-socket inferior)) (match (read (inferior-socket inferior)) (('values objects ...) (apply values (map sexp->object objects))) (('exception key objects ...) (apply throw key (map sexp->object objects))))) +(define (send-inferior-request exp inferior) + (write exp (inferior-socket inferior)) + (newline (inferior-socket inferior))) + +(define (inferior-eval exp inferior) + "Evaluate EXP in INFERIOR." + (send-inferior-request exp inferior) + (read-inferior-response inferior)) + ;;; ;;; Inferior packages. @@ -162,8 +217,8 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! <inferior-package> write-inferior-package) -(define (inferior-packages inferior) - "Return the list of packages known to INFERIOR." +(define (%inferior-packages inferior) + "Compute the list of inferior packages from INFERIOR." (let ((result (inferior-eval '(fold-packages (lambda (package result) (let ((id (object-address package))) @@ -179,6 +234,33 @@ equivalent. Return #f if the inferior could not be launched." (inferior-package inferior name version id))) result))) +(define (inferior-packages inferior) + "Return the list of packages known to INFERIOR." + (force (inferior-package-promise inferior))) + +(define (%inferior-package-table inferior) + "Compute a package lookup table for INFERIOR." + (fold (lambda (package table) + (vhash-cons (inferior-package-name package) package + table)) + vlist-null + (inferior-packages inferior))) + +(define* (lookup-inferior-packages inferior name #:optional version) + "Return the sorted list of inferior packages matching NAME in INFERIOR, with +highest version numbers first. If VERSION is true, return only packages with +a version number prefixed by VERSION." + ;; This is the counterpart of 'find-packages-by-name'. + (sort (filter (lambda (package) + (or (not version) + (version-prefix? version + (inferior-package-version package)))) + (vhash-fold* cons '() name + (force (inferior-package-table inferior)))) + (lambda (p1 p2) + (version>? (inferior-package-version p1) + (inferior-package-version p2))))) + (define (inferior-package-field package getter) "Return the field of PACKAGE, an inferior package, accessed with GETTER." (let ((inferior (inferior-package-inferior package)) @@ -216,3 +298,261 @@ record." (location->source-properties loc))) package-location)))) + +(define (inferior-package-input-field package field) + "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an +inferior package." + (define field* + `(compose (lambda (inputs) + (map (match-lambda + ;; XXX: Origins are not handled. + ((label (? package? package) rest ...) + (let ((id (object-address package))) + (hashv-set! %package-table id package) + `(,label (package ,id + ,(package-name package) + ,(package-version package)) + ,@rest))) + (x + x)) + inputs)) + ,field)) + + (define inputs + (inferior-package-field package field*)) + + (define inferior + (inferior-package-inferior package)) + + (map (match-lambda + ((label ('package id name version) . rest) + ;; XXX: eq?-ness of inferior packages is not preserved here. + `(,label ,(inferior-package inferior name version id) + ,@rest)) + (x x)) + inputs)) + +(define inferior-package-inputs + (cut inferior-package-input-field <> 'package-inputs)) + +(define inferior-package-native-inputs + (cut inferior-package-input-field <> 'package-native-inputs)) + +(define inferior-package-propagated-inputs + (cut inferior-package-input-field <> 'package-propagated-inputs)) + +(define inferior-package-transitive-propagated-inputs + (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) + +(define (%inferior-package-search-paths package field) + "Return the list of search path specificiations of PACKAGE, an inferior +package." + (define paths + (inferior-package-field package + `(compose (lambda (paths) + (map (@ (guix search-paths) + search-path-specification->sexp) + paths)) + ,field))) + + (map sexp->search-path-specification paths)) + +(define inferior-package-native-search-paths + (cut %inferior-package-search-paths <> 'package-native-search-paths)) + +(define inferior-package-search-paths + (cut %inferior-package-search-paths <> 'package-search-paths)) + +(define inferior-package-transitive-native-search-paths + (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths)) + +(define (proxy client backend) ;adapted from (guix ssh) + "Proxy communication between CLIENT and BACKEND until CLIENT closes the +connection, at which point CLIENT is closed (both CLIENT and BACKEND must be +input/output ports.)" + (define (select* read write except) + ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4: + ;; since 'select' sometimes returns non-empty sets for no good reason, + ;; call 'select' a second time with a zero timeout to filter out incorrect + ;; replies. + (match (select read write except) + ((read write except) + (select read write except 0)))) + + ;; Use buffered ports so that 'get-bytevector-some' returns up to the + ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. + (setvbuf client _IOFBF 65536) + (setvbuf backend _IOFBF 65536) + + (let loop () + (match (select* (list client backend) '() '()) + ((reads () ()) + (when (memq client reads) + (match (get-bytevector-some client) + ((? eof-object?) + (close-port client)) + (bv + (put-bytevector backend bv) + (force-output backend)))) + (when (memq backend reads) + (match (get-bytevector-some backend) + (bv + (put-bytevector client bv) + (force-output client)))) + (unless (port-closed? client) + (loop)))))) + +(define* (inferior-package-derivation store package + #:optional + (system (%current-system)) + #:key target) + "Return the derivation for PACKAGE, an inferior package, built for SYSTEM +and cross-built for TARGET if TARGET is true. The inferior corresponding to +PACKAGE must be live." + ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to + ;; it and use it as its store. This ensures the inferior uses the same + ;; store, with the same options, the same per-session GC roots, etc. + (call-with-temporary-directory + (lambda (directory) + (chmod directory #o700) + (let* ((name (string-append directory "/inferior")) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (inferior (inferior-package-inferior package)) + (major (nix-server-major-version store)) + (minor (nix-server-minor-version store)) + (proto (logior major minor))) + (bind socket AF_UNIX name) + (listen socket 1024) + (send-inferior-request + `(let ((socket (socket AF_UNIX SOCK_STREAM 0))) + (connect socket AF_UNIX ,name) + + ;; 'port->connection' appeared in June 2018 and we can hardly + ;; emulate it on older versions. Thus fall back to + ;; 'open-connection', at the risk of talking to the wrong daemon or + ;; having our build result reclaimed (XXX). + (let* ((store (if (defined? 'port->connection) + (port->connection socket #:version ,proto) + (open-connection))) + (package (hashv-ref %package-table + ,(inferior-package-id package))) + (drv ,(if target + `(package-cross-derivation store package + ,target + ,system) + `(package-derivation store package + ,system)))) + (close-connection store) + (close-port socket) + (derivation-file-name drv))) + inferior) + (match (accept socket) + ((client . address) + (proxy client (nix-server-socket store)))) + (close-port socket) + (read-derivation-from-file (read-inferior-response inferior)))))) + +(define inferior-package->derivation + (store-lift inferior-package-derivation)) + +(define-gexp-compiler (package-compiler (package <inferior-package>) system + target) + ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. + (inferior-package->derivation package system #:target target)) + + +;;; +;;; Manifest entries. +;;; + +(define* (inferior-package->manifest-entry package + #:optional (output "out") + #:key (parent (delay #f)) + (properties '())) + "Return a manifest entry for the OUTPUT of package PACKAGE." + ;; For each dependency, keep a promise pointing to its "parent" entry. + (letrec* ((deps (map (match-lambda + ((label package) + (inferior-package->manifest-entry package + #:parent (delay entry))) + ((label package output) + (inferior-package->manifest-entry package output + #:parent (delay entry)))) + (inferior-package-propagated-inputs package))) + (entry (manifest-entry + (name (inferior-package-name package)) + (version (inferior-package-version package)) + (output output) + (item package) + (dependencies (delete-duplicates deps)) + (search-paths + (inferior-package-transitive-native-search-paths package)) + (parent parent) + (properties properties)))) + entry)) + + +;;; +;;; Cached inferiors. +;;; + +(define %inferior-cache-directory + ;; Directory for cached inferiors (GC roots). + (make-parameter (string-append (cache-directory #:ensure? #f) + "/inferiors"))) + +(define* (inferior-for-channels channels + #:key + (cache-directory (%inferior-cache-directory)) + (ttl (* 3600 24 30))) + "Return an inferior for CHANNELS, a list of channels. Use the cache at +CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This +procedure opens a new connection to the build daemon. + +This is a convenience procedure that people may use in manifests passed to +'guix package -m', for instance." + (with-store store + (let () + (define instances + (latest-channel-instances store channels)) + + (define key + (bytevector->base32-string + (sha256 + (string->utf8 + (string-concatenate (map channel-instance-commit instances)))))) + + (define cached + (string-append cache-directory "/" key)) + + (define (base32-encoded-sha256? str) + (= (string-length str) 52)) + + (define (cache-entries directory) + (map (lambda (file) + (string-append directory "/" file)) + (scandir directory base32-encoded-sha256?))) + + (define symlink* + (lift2 symlink %store-monad)) + + (define add-indirect-root* + (store-lift add-indirect-root)) + + (mkdir-p cache-directory) + (maybe-remove-expired-cache-entries cache-directory + cache-entries + #:entry-expiration + (file-expiration-time ttl)) + + (if (file-exists? cached) + (open-inferior cached) + (run-with-store store + (mlet %store-monad ((profile + (channel-instances->derivation instances))) + (mbegin %store-monad + (show-what-to-build* (list profile)) + (built-derivations (list profile)) + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return (open-inferior cached))))))))) diff --git a/guix/profiles.scm b/guix/profiles.scm index 8acfcff8c1..669ebe04e5 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -314,12 +314,31 @@ file name." "Return a list of manifest entries, one for each item listed in PACKAGES. Elements of PACKAGES can be either package objects or package/string tuples denoting a specific output of a package." + (define inferiors-loaded? + ;; This hack allows us to provide seamless integration for inferior + ;; packages while not having a hard dependency on (guix inferior). + (resolve-module '(guix inferior) #f #f #:ensure #f)) + + (define (inferior->entry) + (module-ref (resolve-interface '(guix inferior)) + 'inferior-package->manifest-entry)) + (manifest (map (match-lambda - ((package output) - (package->manifest-entry package output)) - ((? package? package) - (package->manifest-entry package))) + ((package output) + (package->manifest-entry package output)) + ((? package? package) + (package->manifest-entry package)) + ((thing output) + (if inferiors-loaded? + ((inferior->entry) thing output) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing)))) + (thing + (if inferiors-loaded? + ((inferior->entry) thing) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing))))) packages))) (define (manifest->gexp manifest) diff --git a/guix/progress.scm b/guix/progress.scm index c9c3cd12a0..53aea1c56d 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -70,11 +70,11 @@ stopped." (($ <progress-reporter> start report stop) (start)))) -(define (progress-reporter-report! reporter) +(define (progress-reporter-report! reporter . args) "Low-level procedure to lead REPORTER to emit a report." (match reporter (($ <progress-reporter> start report stop) - (report)))) + (apply report args)))) (define (stop-progress-reporter! reporter) "Low-level procedure to stop REPORTER." diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 10e1a99e54..39aebb18e2 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -180,9 +180,25 @@ Download and deploy the latest version of Guix.\n")) (define (honor-x509-certificates store) "Use the right X.509 certificates for Git checkouts over HTTPS." - (let ((file (getenv "SSL_CERT_FILE")) + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) - (if (or (and file (file-exists? file)) + (if (or file (and=> (stat directory #f) (lambda (st) (> (stat:nlink st) 2)))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 6d31dfdaa4..50c6a22064 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -837,8 +837,8 @@ REPORTER, which should be a <progress-reporter> object." (make-custom-binary-input-port "progress-port-proc" read! #f #f (lambda () - (close-connection port) - (stop))))))) + (stop) + (close-port port))))))) (define-syntax with-networking (syntax-rules () diff --git a/guix/serialization.scm b/guix/serialization.scm index 129374f541..87ad7eeec0 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -301,8 +301,7 @@ result of 'lstat'; exclude entries for which SELECT? does not return true." (filter-map (lambda (base) (let ((file (string-append directory "/" base))) - (and (not (member base '("." ".."))) - (select? file (lstat file)) + (and (select? file (lstat file)) base))) basenames)) diff --git a/guix/store/database.scm b/guix/store/database.scm index 0879a95d0b..341276bc30 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -23,6 +23,7 @@ #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) + #:use-module (guix progress) #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) @@ -234,7 +235,8 @@ be used internally by the daemon's build hook." #:prefix prefix #:state-directory state-directory #:deduplicate? deduplicate? #:reset-timestamps? reset-timestamps? - #:schema schema)) + #:schema schema + #:log-port (%make-void-port "w"))) (define %epoch ;; When it all began. @@ -245,12 +247,14 @@ be used internally by the daemon's build hook." (deduplicate? #t) (reset-timestamps? #t) registration-time - (schema (sql-schema))) + (schema (sql-schema)) + (log-port (current-error-port))) "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\"." +registration time to be recorded in the database; #f means \"now\". +Write a progress report to LOG-PORT." ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and @@ -286,20 +290,32 @@ registration time to be recorded in the database; #f means \"now\"." (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) - (let-values (((hash nar-size) (nar-sha256 real-file-name))) + ;; When TO-REGISTER is already registered, skip it. This makes a + ;; significant differences when 'register-closures' is called + ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. + (unless (path-id db to-register) (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-file-name hash #:store store-dir)))) + (let-values (((hash nar-size) (nar-sha256 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-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)))) + (let* ((prefix (format #f "registering ~a items" (length items))) + (progress (progress-reporter/bar (length items) + prefix log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (item) + (register db item) + (report)) + items))))))) |