summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <marius@gnu.org>2021-06-19 17:38:47 +0200
committerMarius Bakke <marius@gnu.org>2021-06-19 17:38:47 +0200
commit6f9a80b331ae41d142a49fbeb94b90ee587b6155 (patch)
tree2da042a6ccf5368c73d6e3d54c2ee02a62d284e4 /guix
parent6500c9a5b364616e38a7e03aa4516fc2d7cee876 (diff)
parentdece03e2b98fc1c2428c2448ce5792f813eb79bf (diff)
downloadguix-patches-6f9a80b331ae41d142a49fbeb94b90ee587b6155.tar
guix-patches-6f9a80b331ae41d142a49fbeb94b90ee587b6155.tar.gz
Merge branch 'master' into core-updates
Note: this merge actually changes the 'curl' and 'python-attrs' derivations, as part of solving caf4a7a2770ef4d05a6e18f40d602e51da749ddc and 12964df69a99de6190422c752fef65ef813f3b6b respectively. 4604d43c0e (gnu: gnutls@3.6.16: Fix cross-compilation.) was ignored because it cannot currently be tested. Conflicts: gnu/local.mk gnu/packages/aidc.scm gnu/packages/boost.scm gnu/packages/curl.scm gnu/packages/nettle.scm gnu/packages/networking.scm gnu/packages/python-xyz.scm gnu/packages/tls.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/build/asdf-build-system.scm3
-rw-r--r--guix/build/profiles.scm86
-rw-r--r--guix/describe.scm6
-rw-r--r--guix/git.scm8
-rw-r--r--guix/grafts.scm56
-rw-r--r--guix/hg-download.scm35
-rw-r--r--guix/import/launchpad.scm17
-rw-r--r--guix/lint.scm25
-rw-r--r--guix/profiles.scm66
-rw-r--r--guix/scripts/environment.scm51
-rw-r--r--guix/scripts/pack.scm2
-rw-r--r--guix/scripts/package.scm5
-rwxr-xr-xguix/scripts/substitute.scm3
-rw-r--r--guix/self.scm4
-rw-r--r--guix/store.scm210
-rw-r--r--guix/swh.scm10
-rw-r--r--guix/transformations.scm4
17 files changed, 362 insertions, 229 deletions
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 7f1037c4f9..6186613e52 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -72,8 +72,7 @@
(define (output-translation source-path
object-output)
- "Return a translation for the system's source path
-to it's binary output."
+ "Return a translation for the system's source path to its binary output."
`((,source-path
:**/ :*.*.*)
(,(library-directory object-output)
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index a40c3f96de..9249977bed 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -20,6 +20,8 @@
#:use-module (guix build union)
#:use-module (guix build utils)
#:use-module (guix search-paths)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
@@ -143,45 +145,71 @@ instead make DIRECTORY a \"real\" directory containing symlinks."
directory))))
(apply throw args))))))
-(define* (build-profile output inputs
- #:key manifest search-paths
- (symlink symlink))
- "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to
-create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create
-OUTPUT/etc/profile with Bash definitions for -all the variables listed in
-SEARCH-PATHS."
+(define (manifest-sexp->inputs+search-paths manifest)
+ "Parse MANIFEST, an sexp as produced by 'manifest->gexp', and return two
+values: the list of store items of its manifest entries, and the list of
+search path specifications."
+ (match manifest ;this must match 'manifest->gexp'
+ (('manifest ('version 3)
+ ('packages (entries ...)))
+ (let loop ((entries entries)
+ (inputs '())
+ (search-paths '()))
+ (match entries
+ (((name version output item
+ ('propagated-inputs deps)
+ ('search-paths paths) _ ...) . rest)
+ (loop (append deps rest)
+ (cons item inputs)
+ (append paths search-paths)))
+ (()
+ (values inputs
+ (delete-duplicates
+ (cons $PATH
+ (map sexp->search-path-specification
+ search-paths))))))))))
+
+(define* (build-profile output manifest
+ #:key (extra-inputs '()) (symlink symlink))
+ "Build a user profile from MANIFEST, an sexp, and EXTRA-INPUTS, a list of
+store items, in directory OUTPUT, using SYMLINK to create symlinks. Create
+OUTPUT/etc/profile with Bash definitions for all the variables listed in the
+search paths of MANIFEST's entries."
(define manifest-file
(string-append output "/manifest"))
- ;; Make the symlinks.
- (union-build output inputs
- #:symlink symlink
- #:log-port (%make-void-port "w"))
+ (let-values (((inputs search-paths)
+ (manifest-sexp->inputs+search-paths manifest)))
- ;; If one of the INPUTS provides a '/manifest' file, delete it. That can
- ;; happen if MANIFEST contains something such as a Guix instance, which is
- ;; ultimately built as a profile.
- (when (file-exists? manifest-file)
- (delete-file manifest-file))
+ ;; Make the symlinks.
+ (union-build output (append extra-inputs inputs)
+ #:symlink symlink
+ #:log-port (%make-void-port "w"))
- ;; Store meta-data.
- (call-with-output-file manifest-file
- (lambda (p)
- (display "\
+ ;; If one of the INPUTS provides a '/manifest' file, delete it. That can
+ ;; happen if MANIFEST contains something such as a Guix instance, which is
+ ;; ultimately built as a profile.
+ (when (file-exists? manifest-file)
+ (delete-file manifest-file))
+
+ ;; Store meta-data.
+ (call-with-output-file manifest-file
+ (lambda (p)
+ (display "\
;; This file was automatically generated and is for internal use only.
;; It cannot be passed to the '--manifest' option.
;; Run 'guix package --export-manifest' if you want to export a file
;; suitable for '--manifest'.\n\n"
- p)
- (pretty-print manifest p)))
+ p)
+ (pretty-print manifest p)))
- ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have
- ;; made 'etc' a symlink to a read-only sub-directory in the store so we need
- ;; to work around that.
- (ensure-writable-directory (string-append output "/etc")
- #:symlink symlink)
+ ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have
+ ;; made 'etc' a symlink to a read-only sub-directory in the store so we
+ ;; need to work around that.
+ (ensure-writable-directory (string-append output "/etc")
+ #:symlink symlink)
- ;; Write 'OUTPUT/etc/profile'.
- (build-etc/profile output search-paths))
+ ;; Write 'OUTPUT/etc/profile'.
+ (build-etc/profile output search-paths)))
;;; profile.scm ends here
diff --git a/guix/describe.scm b/guix/describe.scm
index 711b7b4290..65cd79094b 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -115,7 +115,11 @@ lives in, or the empty list if this is not applicable."
"Return manifest entries corresponding to extra channels--i.e., not the
'guix' channel."
(remove (lambda (entry)
- (string=? (manifest-entry-name entry) "guix"))
+ (or (string=? (manifest-entry-name entry) "guix")
+
+ ;; If ENTRY lacks the 'source' property, it's not an entry
+ ;; from 'guix pull'. See <https://bugs.gnu.org/48778>.
+ (not (assq 'source (manifest-entry-properties entry)))))
(current-profile-entries))))
(define current-channels
diff --git a/guix/git.scm b/guix/git.scm
index 57fa2ca1ee..9c6f326c36 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -424,6 +424,14 @@ it unchanged."
;; REPOSITORY as soon as possible.
(repository-close! repository)
+ ;; Update CACHE-DIRECTORY's mtime to so the cache logic sees it.
+ (match (gettimeofday)
+ ((seconds . microseconds)
+ (let ((nanoseconds (* 1000 microseconds)))
+ (utime cache-directory
+ seconds seconds
+ nanoseconds nanoseconds))))
+
;; When CACHE-DIRECTORY is a sub-directory of the default cache
;; directory, remove expired checkouts that are next to it.
(let ((parent (dirname cache-directory)))
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 7f5b97c39d..0ffda8f9aa 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -25,10 +25,10 @@
#:use-module ((guix utils) #:select (%current-system))
#:use-module (guix sets)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:export (graft?
@@ -173,10 +173,20 @@ references."
items))))
(remove (cut member <> self) refs)))
+(define %graft-cache
+ ;; Cache that maps derivation/outputs/grafts tuples to lists of grafts.
+ (allocate-store-connection-cache 'grafts))
+
+(define record-cache-lookup!
+ (cache-lookup-recorder "derivation-graft-cache"
+ "Derivation graft cache"))
+
(define-syntax-rule (with-cache key exp ...)
"Cache the value of monadic expression EXP under KEY."
- (mlet %state-monad ((cache (current-state)))
- (match (vhash-assoc key cache)
+ (mlet* %state-monad ((cache (current-state))
+ (result -> (vhash-assoc key cache)))
+ (record-cache-lookup! result cache)
+ (match result
((_ . result) ;cache hit
(return result))
(#f ;cache miss
@@ -218,10 +228,10 @@ have no corresponding element in the resulting list."
((set-contains? visited drv)
(loop rest items result visited))
(else
- (let*-values (((inputs)
- (map derivation-input-derivation
- (derivation-inputs drv)))
- ((result items)
+ (let* ((inputs
+ (map derivation-input-derivation
+ (derivation-inputs drv)))
+ (result items
(fold2 lookup-derivers
result items inputs)))
(loop (append rest inputs)
@@ -266,7 +276,7 @@ derivations to the corresponding set of grafts."
#:system system)))))
(reference-origins drv items)))
- (with-cache (cons (derivation-file-name drv) outputs)
+ (with-cache (list (derivation-file-name drv) outputs grafts)
(match (non-self-references store drv outputs)
(() ;no dependencies
(return grafts))
@@ -304,17 +314,25 @@ derivations to the corresponding set of grafts."
"Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
DRV, and graft DRV itself to refer to those grafted dependencies."
- (match (run-with-state
- (cumulative-grafts store drv grafts
- #:outputs outputs
- #:guile guile #:system system)
- vlist-null) ;the initial cache
- ((first . rest)
- ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
- ;; applicable to DRV and nothing needs to be done.
- (if (equal? drv (graft-origin first))
- (graft-replacement first)
- drv))))
+ (let ((grafts cache
+ (run-with-state
+ (cumulative-grafts store drv grafts
+ #:outputs outputs
+ #:guile guile #:system system)
+ (store-connection-cache store %graft-cache))))
+
+ ;; Save CACHE in STORE to benefit from it on the next call.
+ ;; XXX: Ideally we'd use %STORE-MONAD and 'mcached' and avoid mutating
+ ;; STORE.
+ (set-store-connection-cache! store %graft-cache cache)
+
+ (match grafts
+ ((first . rest)
+ ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
+ ;; applicable to DRV and nothing needs to be done.
+ (if (equal? drv (graft-origin first))
+ (graft-replacement first)
+ drv)))))
;; The following might feel more at home in (guix packages) but since (guix
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index eb7c345489..382c34922a 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -35,7 +35,6 @@
hg-reference?
hg-reference-url
hg-reference-changeset
- hg-reference-recursive?
hg-predicate
hg-fetch
hg-version
@@ -67,6 +66,13 @@
"Return a fixed-output derivation that fetches REF, a <hg-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
+ (define inputs
+ ;; The 'swh-download' procedure requires tar and gzip.
+ `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
+ 'gzip))
+ ("tar" ,(module-ref (resolve-interface '(gnu packages base))
+ 'tar))))
+
(define guile-zlib
(module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
@@ -79,7 +85,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(define modules
(delete '(guix config)
(source-module-closure '((guix build hg)
- (guix build download-nar)))))
+ (guix build download-nar)
+ (guix swh)))))
(define build
(with-imported-modules modules
@@ -87,13 +94,33 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
guile-zlib)
#~(begin
(use-modules (guix build hg)
- (guix build download-nar))
+ (guix build utils) ;for `set-path-environment-variable'
+ (guix build download-nar)
+ (guix swh)
+ (ice-9 match))
+
+ (set-path-environment-variable "PATH" '("bin")
+ (match '#+inputs
+ (((names dirs outputs ...) ...)
+ dirs)))
+
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
(or (hg-fetch '#$(hg-reference-url ref)
'#$(hg-reference-changeset ref)
#$output
#:hg-command (string-append #+hg "/bin/hg"))
- (download-nar #$output))))))
+ (download-nar #$output)
+ ;; As a last resort, attempt to download from Software Heritage.
+ ;; Disable X.509 certificate verification to avoid depending
+ ;; on nss-certs--we're authenticating the checkout anyway.
+ (parameterize ((%verify-swh-certificate? #f))
+ (format (current-error-port)
+ "Trying to download from Software Heritage...~%")
+ (swh-download #$(hg-reference-url ref)
+ #$(hg-reference-changeset ref)
+ #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm
index fd3cfa8444..a52b39a085 100644
--- a/guix/import/launchpad.scm
+++ b/guix/import/launchpad.scm
@@ -110,15 +110,14 @@ for example, 'linuxdcpp'. Return #f if there is no releases."
char-set:digit)
(assoc-ref x "version"))))
- (assoc-ref
- (last (remove
- pre-release?
- (vector->list
- (assoc-ref (json-fetch
- (string-append "https://api.launchpad.net/1.0/"
- package-name "/releases"))
- "entries"))))
- "version"))
+ (match (json-fetch
+ (string-append "https://api.launchpad.net/1.0/"
+ package-name "/releases"))
+ (#f #f) ;404 or similar
+ (json
+ (assoc-ref
+ (last (remove pre-release? (vector->list (assoc-ref json "entries"))))
+ "version"))))
(define (latest-release pkg)
"Return an <upstream-source> for the latest release of PKG."
diff --git a/guix/lint.scm b/guix/lint.scm
index 5cd6db5842..d65d5ce8f9 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -300,6 +300,15 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
infractions)
#:field 'description)))))
+ (define (check-no-trailing-whitespace description)
+ "Check that DESCRIPTION doesn't have trailing whitespace."
+ (if (string-suffix? " " description)
+ (list
+ (make-warning package
+ (G_ "description contains trailing whitespace")
+ #:field 'description))
+ '()))
+
(let ((description (package-description package)))
(if (string? description)
(append
@@ -309,6 +318,7 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
;; Use raw description for this because Texinfo rendering
;; automatically fixes end of sentence space.
(check-end-of-sentence-space description)
+ (check-no-trailing-whitespace description)
(match (check-texinfo-markup description)
((and warning (? lint-warning?)) (list warning))
(plain-description
@@ -478,13 +488,23 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(G_ "Texinfo markup in synopsis is invalid")
#:field 'synopsis)))))
+ (define (check-no-trailing-whitespace synopsis)
+ "Check that SYNOPSIS doesn't have trailing whitespace."
+ (if (string-suffix? " " synopsis)
+ (list
+ (make-warning package
+ (G_ "synopsis contains trailing whitespace")
+ #:field 'synopsis))
+ '()))
+
(define checks
(list check-proper-start
check-final-period
check-start-article
check-start-with-package-name
check-synopsis-length
- check-texinfo-markup))
+ check-texinfo-markup
+ check-no-trailing-whitespace))
(match (package-synopsis package)
(""
@@ -781,7 +801,8 @@ warnings."
((blank? line)
(loop))
((or (string-prefix? "--- " line)
- (string-prefix? "+++ " line))
+ (string-prefix? "+++ " line)
+ (string-prefix? "diff --git " line))
(list (make-warning package
(G_ "~a: patch lacks comment and \
upstream status")
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 5f9a8a87a9..ebd671c82e 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -11,6 +11,7 @@
;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -54,6 +55,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:autoload (srfi srfi-98) (get-environment-variables)
#:export (&profile-error
profile-error?
profile-error-profile
@@ -127,6 +129,7 @@
%default-profile-hooks
profile-derivation
profile-search-paths
+ load-profile
profile
profile?
@@ -1713,12 +1716,10 @@ are cross-built for TARGET."
(mapm/accumulate-builds (lambda (hook)
(hook manifest))
hooks))))
- (define inputs
- (append (filter-map (lambda (drv)
- (and (derivation? drv)
- (gexp-input drv)))
- extras)
- (manifest-inputs manifest)))
+ (define extra-inputs
+ (filter-map (lambda (drv)
+ (and (derivation? drv) (gexp-input drv)))
+ extras))
(define glibc-utf8-locales ;lazy reference
(module-ref (resolve-interface '(gnu packages base))
@@ -1752,20 +1753,11 @@ are cross-built for TARGET."
#+(if locales? set-utf8-locale #t)
- (define search-paths
- ;; Search paths of MANIFEST's packages, converted back to their
- ;; record form.
- (map sexp->search-path-specification
- (delete-duplicates
- '#$(map search-path-specification->sexp
- (manifest-search-paths manifest)))))
-
- (build-profile #$output '#$inputs
+ (build-profile #$output '#$(manifest->gexp manifest)
+ #:extra-inputs '#$extra-inputs
#:symlink #$(if relative-symlinks?
#~symlink-relative
- #~symlink)
- #:manifest '#$(manifest->gexp manifest)
- #:search-paths search-paths))))
+ #~symlink)))))
(gexp->derivation name builder
#:system system
@@ -1828,6 +1820,44 @@ already effective."
(evaluate-search-paths (manifest-search-paths manifest)
(list profile) getenv))
+(define %precious-variables
+ ;; Environment variables in the default 'load-profile' white list.
+ '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
+
+(define (purify-environment white-list white-list-regexps)
+ "Unset all environment variables except those that match the regexps in
+WHITE-LIST-REGEXPS and those listed in WHITE-LIST."
+ (for-each unsetenv
+ (remove (lambda (variable)
+ (or (member variable white-list)
+ (find (cut regexp-exec <> variable)
+ white-list-regexps)))
+ (match (get-environment-variables)
+ (((names . _) ...)
+ names)))))
+
+(define* (load-profile profile
+ #:optional (manifest (profile-manifest profile))
+ #:key pure? (white-list-regexps '())
+ (white-list %precious-variables))
+ "Set the environment variables specified by MANIFEST for PROFILE. When
+PURE? is #t, unset the variables in the current environment except those that
+match the regexps in WHITE-LIST-REGEXPS and those listed in WHITE-LIST.
+Otherwise, augment existing environment variables with additional search
+paths."
+ (when pure?
+ (purify-environment white-list white-list-regexps))
+ (for-each (match-lambda
+ ((($ <search-path-specification> variable _ separator) . value)
+ (let ((current (getenv variable)))
+ (setenv variable
+ (if (and current (not pure?))
+ (if separator
+ (string-append value separator current)
+ value)
+ value)))))
+ (profile-search-paths profile manifest)))
+
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 5ceb86f7a9..6958bd6238 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -52,50 +52,9 @@
#:export (assert-container-features
guix-environment))
-;; Protect some env vars from purification. Borrowed from nix-shell.
-(define %precious-variables
- '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
-
(define %default-shell
(or (getenv "SHELL") "/bin/sh"))
-(define (purify-environment white-list)
- "Unset all environment variables except those that match the regexps in
-WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of
-variables such as 'HOME' and 'USER' are left untouched."
- (for-each unsetenv
- (remove (lambda (variable)
- (or (member variable %precious-variables)
- (find (cut regexp-exec <> variable)
- white-list)))
- (match (get-environment-variables)
- (((names . _) ...)
- names)))))
-
-(define* (create-environment profile manifest
- #:key pure? (white-list '()))
- "Set the environment variables specified by MANIFEST for PROFILE. When
-PURE? is #t, unset the variables in the current environment except those that
-match the regexps in WHITE-LIST. Otherwise, augment existing environment
-variables with additional search paths."
- (when pure?
- (purify-environment white-list))
- (for-each (match-lambda
- ((($ <search-path-specification> variable _ separator) . value)
- (let ((current (getenv variable)))
- (setenv variable
- (if (and current (not pure?))
- (if separator
- (string-append value separator current)
- value)
- value)))))
- (profile-search-paths profile manifest))
-
- ;; Give users a way to know that they're in 'guix environment', so they can
- ;; adjust 'PS1' accordingly, for instance. Set it to PROFILE so users can
- ;; conveniently access its contents.
- (setenv "GUIX_ENVIRONMENT" profile))
-
(define* (show-search-paths profile manifest #:key pure?)
"Display the search paths of MANIFEST applied to PROFILE. When PURE? is #t,
do not augment existing environment variables with additional search paths."
@@ -425,8 +384,14 @@ regexps in WHITE-LIST."
;; Properly handle SIGINT, so pressing C-c in an interactive terminal
;; application works.
(sigaction SIGINT SIG_DFL)
- (create-environment profile manifest
- #:pure? pure? #:white-list white-list)
+ (load-profile profile manifest
+ #:pure? pure? #:white-list-regexps white-list)
+
+ ;; Give users a way to know that they're in 'guix environment', so they can
+ ;; adjust 'PS1' accordingly, for instance. Set it to PROFILE so users can
+ ;; conveniently access its contents.
+ (setenv "GUIX_ENVIRONMENT" profile)
+
(match command
((program . args)
(apply execlp program program args))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index d12fbaff6a..4c7039cce9 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -619,7 +619,7 @@ the image."
#$profile
#:repository tag
#:database #+database
- #:system (or #$target (utsname:machine (uname)))
+ #:system (or #$target %host-type)
#:environment environment
#:entry-point
#$(and entry-point
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 6db83807af..694959d326 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1044,7 +1044,10 @@ processed, #f otherwise."
(warn-about-old-distro)
- (when (and (null? files) (manifest-transaction-null? trans))
+ (when (and (null? files) (manifest-transaction-null? trans)
+ (not (any (match-lambda
+ ((key . _) (assoc-ref %actions key)))
+ opts)))
;; We can reach this point because the user did not specify any action
;; (as in "guix package"), did not specify any package (as in "guix
;; install"), or because there's nothing to upgrade (as when running
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 44448ff3e9..3ea1c73e10 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -643,7 +643,8 @@ found."
(#f
;; This can only happen when this script is not invoked by the
;; daemon.
- '("http://ci.guix.gnu.org"))))
+ '("http://ci.guix.gnu.org"
+ "http://bordeaux.guix.gnu.org"))))
;; In order to prevent using large number of discovered local substitute
;; servers, limit the local substitute urls list size.
diff --git a/guix/self.scm b/guix/self.scm
index 666245321b..87d00ea64f 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -719,7 +719,9 @@ load path."
("share/guix/ci.guix.gnu.org.pub" ;alias
,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub"))
("share/guix/ci.guix.info.pub" ;alias
- ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub")))))
+ ,(file-append* source "/etc/substitutes/berlin.guix.gnu.org.pub"))
+ ("share/guix/bordeaux.guix.gnu.org.pub"
+ ,(file-append* source "/etc/substitutes/bordeaux.guix.gnu.org.pub")))))
(define* (whole-package name modules dependencies
#:key
diff --git a/guix/store.scm b/guix/store.scm
index cf5d5eeccc..1ab2b08b47 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -36,6 +36,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module ((ice-9 control) #:select (let/ec))
+ #:use-module (ice-9 atomic)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
@@ -47,7 +48,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 popen)
- #:use-module (ice-9 threads)
+ #:autoload (ice-9 threads) (current-processor-count)
#:use-module (ice-9 format)
#:use-module (web uri)
#:export (%daemon-socket-uri
@@ -68,6 +69,7 @@
nix-server-socket
current-store-protocol-version ;for internal use
+ cache-lookup-recorder ;for internal use
mcached
&store-error store-error?
@@ -87,6 +89,11 @@
nix-protocol-error-message
nix-protocol-error-status
+ allocate-store-connection-cache
+ store-connection-cache
+ set-store-connection-cache
+ set-store-connection-cache!
+
hash-algo
build-mode
@@ -141,7 +148,6 @@
built-in-builders
references
references/cached
- references/substitutes
references*
query-path-info*
requisites
@@ -383,8 +389,8 @@
;; the session.
(ats-cache store-connection-add-to-store-cache)
(atts-cache store-connection-add-text-to-store-cache)
- (object-cache store-connection-object-cache
- (default vlist-null)) ;vhash
+ (caches store-connection-caches
+ (default '#())) ;vector
(built-in-builders store-connection-built-in-builders
(default (delay '())))) ;promise
@@ -586,6 +592,10 @@ for this connection will be pinned. Return a server object."
(write-int (if reserve-space? 1 0) port))
(letrec* ((built-in-builders
(delay (%built-in-builders conn)))
+ (caches
+ (make-vector
+ (atomic-box-ref %store-connection-caches)
+ vlist-null))
(conn
(%make-store-connection port
(protocol-major v)
@@ -593,7 +603,7 @@ for this connection will be pinned. Return a server object."
output flush
(make-hash-table 100)
(make-hash-table 100)
- vlist-null
+ caches
built-in-builders)))
(let loop ((done? (process-stderr conn)))
(or done? (process-stderr conn)))
@@ -616,7 +626,9 @@ connection. Use with care."
output flush
(make-hash-table 100)
(make-hash-table 100)
- vlist-null
+ (make-vector
+ (atomic-box-ref %store-connection-caches)
+ vlist-null)
(delay (%built-in-builders connection))))
connection))
@@ -775,7 +787,8 @@ encoding conversion errors."
(map (if (false-if-exception (resolve-interface '(gnutls)))
(cut string-append "https://" <>)
(cut string-append "http://" <>))
- '("ci.guix.gnu.org")))
+ '("ci.guix.gnu.org"
+ "bordeaux.guix.gnu.org")))
(define (current-user-name)
"Return the name of the calling user."
@@ -1464,73 +1477,6 @@ error if there is no such root."
"Return the list of references of PATH."
store-path-list))
-(define %reference-cache
- ;; Brute-force cache mapping store items to their list of references.
- ;; Caching matters because when building a profile in the presence of
- ;; grafts, we keep calling 'graft-derivation', which in turn calls
- ;; 'references/substitutes' many times with the same arguments. Ideally we
- ;; would use a cache associated with the daemon connection instead (XXX).
- (make-hash-table 100))
-
-(define (references/cached store item)
- "Like 'references', but cache results."
- (or (hash-ref %reference-cache item)
- (let ((references (references store item)))
- (hash-set! %reference-cache item references)
- references)))
-
-(define (references/substitutes store items)
- "Return the list of list of references of ITEMS; the result has the same
-length as ITEMS. Query substitute information for any item missing from the
-store at once. Raise a '&store-protocol-error' exception if reference
-information for one of ITEMS is missing."
- (let* ((requested items)
- (local-refs (map (lambda (item)
- (or (hash-ref %reference-cache item)
- (guard (c ((store-protocol-error? c) #f))
- (references store item))))
- items))
- (missing (fold-right (lambda (item local-ref result)
- (if local-ref
- result
- (cons item result)))
- '()
- items local-refs))
-
- ;; Query all the substitutes at once to minimize the cost of
- ;; launching 'guix substitute' and making HTTP requests.
- (substs (if (null? missing)
- '()
- (substitutable-path-info store missing))))
- (when (< (length substs) (length missing))
- (raise (condition (&store-protocol-error
- (message "cannot determine \
-the list of references")
- (status 1)))))
-
- ;; Intersperse SUBSTS and LOCAL-REFS.
- (let loop ((items items)
- (local-refs local-refs)
- (result '()))
- (match items
- (()
- (let ((result (reverse result)))
- (for-each (cut hash-set! %reference-cache <> <>)
- requested result)
- result))
- ((item items ...)
- (match local-refs
- ((#f tail ...)
- (loop items tail
- (cons (any (lambda (subst)
- (and (string=? (substitutable-path subst) item)
- (substitutable-references subst)))
- substs)
- result)))
- ((head tail ...)
- (loop items tail
- (cons head result)))))))))
-
(define* (fold-path store proc seed paths
#:optional (relatives (cut references store <>)))
"Call PROC for each of the RELATIVES of PATHS, exactly once, and return the
@@ -1801,6 +1747,77 @@ This makes sense only when the daemon was started with '--cache-failures'."
;;;
+;;; Per-connection caches.
+;;;
+
+;; Number of currently allocated store connection caches--things that go in
+;; the 'caches' vector of <store-connection>.
+(define %store-connection-caches (make-atomic-box 0))
+
+(define (allocate-store-connection-cache name)
+ "Allocate a new cache for store connections and return its identifier. Said
+identifier can be passed as an argument to "
+ (let loop ((current (atomic-box-ref %store-connection-caches)))
+ (let ((previous (atomic-box-compare-and-swap! %store-connection-caches
+ current (+ current 1))))
+ (if (= previous current)
+ current
+ (loop current)))))
+
+(define %object-cache-id
+ ;; The "object cache", mapping lowerable objects such as <package> records
+ ;; to derivations.
+ (allocate-store-connection-cache 'object-cache))
+
+(define (vector-set vector index value)
+ (let ((new (vector-copy vector)))
+ (vector-set! new index value)
+ new))
+
+(define (store-connection-cache store cache)
+ "Return the cache of STORE identified by CACHE, an identifier as returned by
+'allocate-store-connection-cache'."
+ (vector-ref (store-connection-caches store) cache))
+
+(define (set-store-connection-cache store cache value)
+ "Return a copy of STORE where CACHE has the given VALUE. CACHE must be a
+value returned by 'allocate-store-connection-cache'."
+ (store-connection
+ (inherit store)
+ (caches (vector-set (store-connection-caches store) cache value))))
+
+(define set-store-connection-caches! ;private
+ (record-modifier <store-connection> 'caches))
+
+(define (set-store-connection-cache! store cache value)
+ "Set STORE's CACHE to VALUE.
+
+This is a mutating version that should be avoided. Prefer the functional
+'set-store-connection-cache' instead, together with using %STORE-MONAD."
+ (vector-set! (store-connection-caches store) cache value))
+
+
+(define %reference-cache-id
+ ;; Cache mapping store items to their list of references. Caching matters
+ ;; because when building a profile in the presence of grafts, we keep
+ ;; calling 'graft-derivation', which in turn calls 'references/cached' many
+ ;; times with the same arguments.
+ (allocate-store-connection-cache 'reference-cache))
+
+(define (references/cached store item)
+ "Like 'references', but cache results."
+ (let ((cache (store-connection-cache store %reference-cache-id)))
+ (match (vhash-assoc item cache)
+ ((_ . references)
+ references)
+ (#f
+ (let* ((references (references store item))
+ (cache (vhash-cons item references cache)))
+ (set-store-connection-cache! store %reference-cache-id cache)
+ references)))))
+
+
+;;;
;;; Store monad.
;;;
@@ -1819,7 +1836,9 @@ This makes sense only when the daemon was started with '--cache-failures'."
(template-directory instantiations %store-monad)
(define* (cache-object-mapping object keys result
- #:key (vhash-cons vhash-consq))
+ #:key
+ (cache %object-cache-id)
+ (vhash-cons vhash-consq))
"Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT.
KEYS is a list of additional keys to match against, for instance a (SYSTEM
TARGET) tuple. Use VHASH-CONS to insert OBJECT into the cache.
@@ -1828,26 +1847,29 @@ OBJECT is typically a high-level object such as a <package> or an <origin>,
and RESULT is typically its derivation."
(lambda (store)
(values result
- (store-connection
- (inherit store)
- (object-cache (vhash-cons object (cons result keys)
- (store-connection-object-cache store)))))))
-
-(define record-cache-lookup!
- (if (profiled? "object-cache")
+ (set-store-connection-cache
+ store cache
+ (vhash-cons object (cons result keys)
+ (store-connection-cache store cache))))))
+
+(define (cache-lookup-recorder component title)
+ "Return a procedure of two arguments to record cache lookups, hits, and
+misses for COMPONENT. The procedure must be passed a Boolean indicating
+whether the cache lookup was a hit, and the actual cache (a vhash)."
+ (if (profiled? component)
(let ((fresh 0)
(lookups 0)
(hits 0)
(size 0))
(register-profiling-hook!
- "object-cache"
+ component
(lambda ()
- (format (current-error-port) "Store object cache:
+ (format (current-error-port) "~a:
fresh caches: ~5@a
lookups: ~5@a
hits: ~5@a (~,1f%)
cache size: ~5@a entries~%"
- fresh lookups hits
+ title fresh lookups hits
(if (zero? lookups)
100.
(* 100. (/ hits lookups)))
@@ -1855,9 +1877,9 @@ and RESULT is typically its derivation."
(lambda (hit? cache)
(set! fresh
- (if (eq? cache vlist-null)
- (+ 1 fresh)
- fresh))
+ (if (eq? cache vlist-null)
+ (+ 1 fresh)
+ fresh))
(set! lookups (+ 1 lookups))
(set! hits (if hit? (+ hits 1) hits))
(set! size (+ (if hit? 0 1)
@@ -1865,13 +1887,16 @@ and RESULT is typically its derivation."
(lambda (x y)
#t)))
+(define record-cache-lookup!
+ (cache-lookup-recorder "object-cache" "Store object cache"))
+
(define-inlinable (lookup-cached-object object keys vhash-fold*)
"Return the cached object in the store connection corresponding to OBJECT
and KEYS; use VHASH-FOLD* to look for OBJECT in the cache. KEYS is a list of
additional keys to match against, and which are compared with 'equal?'.
Return #f on failure and the cached result otherwise."
(lambda (store)
- (let* ((cache (store-connection-object-cache store))
+ (let* ((cache (store-connection-cache store %object-cache-id))
;; Escape as soon as we find the result. This avoids traversing
;; the whole vlist chain and significantly reduces the number of
@@ -2048,9 +2073,6 @@ the store."
;; when using 'gexp->derivation' and co.
(make-parameter #f))
-(define set-store-connection-object-cache!
- (record-modifier <store-connection> 'object-cache))
-
(define* (run-with-store store mval
#:key
(guile-for-build (%guile-for-build))
@@ -2070,8 +2092,8 @@ connection, and return the result."
(when (and store new-store)
;; Copy the object cache from NEW-STORE so we don't fully discard
;; the state.
- (let ((cache (store-connection-object-cache new-store)))
- (set-store-connection-object-cache! store cache)))
+ (let ((caches (store-connection-caches new-store)))
+ (set-store-connection-caches! store caches)))
result))))
diff --git a/guix/swh.scm b/guix/swh.scm
index f6d5241e06..b5c800011d 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -455,8 +456,13 @@ URL could not be found."
((visit . _)
(let ((snapshot (visit-snapshot visit)))
(match (and=> (find (lambda (branch)
- (string=? (string-append "refs/tags/" tag)
- (branch-name branch)))
+ (or
+ ;; Git specific.
+ (string=? (string-append "refs/tags/" tag)
+ (branch-name branch))
+ ;; Hg specific.
+ (string=? tag
+ (branch-name branch))))
(snapshot-branches snapshot))
branch-target)
((? release? release)
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 4e9260350c..b0c09a0c92 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -25,7 +25,7 @@
#:autoload (guix download) (download-to-store)
#:autoload (guix git-download) (git-reference? git-reference-url)
#:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
- #:autoload (guix upstream) (package-latest-release*
+ #:autoload (guix upstream) (package-latest-release
upstream-source-version
upstream-source-signature-urls)
#:use-module (guix utils)
@@ -518,7 +518,7 @@ additional patches."
"Return a procedure that rewrites package graphs such that those in SPECS
are replaced by their latest upstream version."
(define (package-with-latest-upstream p)
- (let ((source (package-latest-release* p)))
+ (let ((source (package-latest-release p)))
(cond ((not source)
(warning
(G_ "could not determine latest upstream release of '~a'~%")