aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/base64.scm18
-rw-r--r--guix/build-system/linux-module.scm4
-rw-r--r--guix/build-system/qt.scm214
-rw-r--r--guix/build-system/r.scm2
-rw-r--r--guix/build/download.scm15
-rw-r--r--guix/build/emacs-build-system.scm14
-rw-r--r--guix/build/emacs-utils.scm8
-rw-r--r--guix/describe.scm18
-rw-r--r--guix/download.scm1
-rw-r--r--guix/gexp.scm2
-rw-r--r--guix/git.scm14
-rw-r--r--guix/gnupg.scm150
-rw-r--r--guix/import/cran.scm5
-rw-r--r--guix/import/utils.scm2
-rw-r--r--guix/inferior.scm14
-rw-r--r--guix/packages.scm4
-rw-r--r--guix/profiles.scm6
-rw-r--r--guix/progress.scm31
-rw-r--r--guix/repl.scm2
-rw-r--r--guix/scripts/archive.scm45
-rw-r--r--guix/scripts/challenge.scm221
-rw-r--r--guix/scripts/pack.scm63
-rw-r--r--guix/scripts/package.scm7
-rwxr-xr-xguix/scripts/substitute.scm36
-rw-r--r--guix/scripts/system.scm14
-rw-r--r--guix/serialization.scm152
-rw-r--r--guix/swh.scm4
-rw-r--r--guix/tests/http.scm6
-rw-r--r--guix/upstream.scm24
29 files changed, 718 insertions, 378 deletions
diff --git a/guix/base64.scm b/guix/base64.scm
index 0fa501eca0..c4fdd9c390 100644
--- a/guix/base64.scm
+++ b/guix/base64.scm
@@ -52,11 +52,10 @@
base64url-alphabet
get-delimited-base64
put-delimited-base64)
- #:use-module (rnrs)
- #:use-module ((srfi srfi-13)
- #:select (string-index
- string-prefix? string-suffix?
- string-concatenate string-trim-both)))
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-60)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports))
(define-syntax define-alias
@@ -67,12 +66,19 @@
;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
;; procedures.
-(define-alias fxbit-field bitwise-bit-field)
+(define-alias fxbit-field bit-field)
(define-alias fxarithmetic-shift ash)
(define-alias fxarithmetic-shift-left ash)
(define-alias fxand logand)
(define-alias fxior logior)
(define-alias fxxor logxor)
+(define-alias fx=? =)
+(define-alias fx+ +)
+(define-alias mod modulo)
+
+(define-syntax-rule (assert exp)
+ (unless exp
+ (throw 'assertion-failure 'exp)))
(define base64-alphabet
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
index 6084d22210..ba76ab85c3 100644
--- a/guix/build-system/linux-module.scm
+++ b/guix/build-system/linux-module.scm
@@ -126,6 +126,7 @@
(outputs '("out"))
(system (%current-system))
(guile #f)
+ (substitutable? #t)
(imported-modules
%linux-module-build-system-modules)
(modules '((guix build linux-module-build-system)
@@ -164,7 +165,8 @@
#:inputs inputs
#:modules imported-modules
#:outputs outputs
- #:guile-for-build guile-for-build))
+ #:guile-for-build guile-for-build
+ #:substitutable? substitutable?))
(define linux-module-build-system
(build-system
diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm
index b776845377..118022ec45 100644
--- a/guix/build-system/qt.scm
+++ b/guix/build-system/qt.scm
@@ -106,60 +106,60 @@
(define* (qt-build store name inputs
- #:key (guile #f)
- (outputs '("out")) (configure-flags ''())
- (search-paths '())
- (make-flags ''())
- (out-of-source? #t)
- (build-type "RelWithDebInfo")
- (tests? #t)
- (test-target "test")
- (parallel-build? #t) (parallel-tests? #f)
- (validate-runpath? #t)
- (patch-shebangs? #t)
- (strip-binaries? #t)
- (strip-flags ''("--strip-debug"))
- (strip-directories ''("lib" "lib64" "libexec"
- "bin" "sbin"))
- (phases '(@ (guix build qt-build-system)
- %standard-phases))
- (qt-wrap-excluded-outputs ''())
- (system (%current-system))
- (imported-modules %qt-build-system-modules)
- (modules '((guix build cmake-build-system)
- (guix build utils))))
+ #:key (guile #f)
+ (outputs '("out")) (configure-flags ''())
+ (search-paths '())
+ (make-flags ''())
+ (out-of-source? #t)
+ (build-type "RelWithDebInfo")
+ (tests? #t)
+ (test-target "test")
+ (parallel-build? #t) (parallel-tests? #f)
+ (validate-runpath? #t)
+ (patch-shebangs? #t)
+ (strip-binaries? #t)
+ (strip-flags ''("--strip-debug"))
+ (strip-directories ''("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ (phases '(@ (guix build qt-build-system)
+ %standard-phases))
+ (qt-wrap-excluded-outputs ''())
+ (system (%current-system))
+ (imported-modules %qt-build-system-modules)
+ (modules '((guix build qt-build-system)
+ (guix build utils))))
"Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE
provides a 'CMakeLists.txt' file as its build system."
(define builder
`(begin
(use-modules ,@modules)
- (cmake-build #:source ,(match (assoc-ref inputs "source")
- (((? derivation? source))
- (derivation->output-path source))
- ((source)
- source)
- (source
- source))
- #:system ,system
- #:outputs %outputs
- #:inputs %build-inputs
- #:search-paths ',(map search-path-specification->sexp
- search-paths)
- #:phases ,phases
- #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs
- #:configure-flags ,configure-flags
- #:make-flags ,make-flags
- #:out-of-source? ,out-of-source?
- #:build-type ,build-type
- #:tests? ,tests?
- #:test-target ,test-target
- #:parallel-build? ,parallel-build?
- #:parallel-tests? ,parallel-tests?
- #:validate-runpath? ,validate-runpath?
- #:patch-shebangs? ,patch-shebangs?
- #:strip-binaries? ,strip-binaries?
- #:strip-flags ,strip-flags
- #:strip-directories ,strip-directories)))
+ (qt-build #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:outputs %outputs
+ #:inputs %build-inputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:phases ,phases
+ #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs
+ #:configure-flags ,configure-flags
+ #:make-flags ,make-flags
+ #:out-of-source? ,out-of-source?
+ #:build-type ,build-type
+ #:tests? ,tests?
+ #:test-target ,test-target
+ #:parallel-build? ,parallel-build?
+ #:parallel-tests? ,parallel-tests?
+ #:validate-runpath? ,validate-runpath?
+ #:patch-shebangs? ,patch-shebangs?
+ #:strip-binaries? ,strip-binaries?
+ #:strip-flags ,strip-flags
+ #:strip-directories ,strip-directories)))
(define guile-for-build
(match guile
@@ -183,33 +183,33 @@ provides a 'CMakeLists.txt' file as its build system."
;;;
(define* (qt-cross-build store name
- #:key
- target native-drvs target-drvs
- (guile #f)
- (outputs '("out"))
- (configure-flags ''())
- (search-paths '())
- (native-search-paths '())
- (make-flags ''())
- (out-of-source? #t)
- (build-type "RelWithDebInfo")
- (tests? #f) ; nothing can be done
- (test-target "test")
- (parallel-build? #t) (parallel-tests? #f)
- (validate-runpath? #t)
- (patch-shebangs? #t)
- (strip-binaries? #t)
- (strip-flags ''("--strip-debug"
- "--enable-deterministic-archives"))
- (strip-directories ''("lib" "lib64" "libexec"
- "bin" "sbin"))
- (phases '(@ (guix build qt-build-system)
+ #:key
+ target native-drvs target-drvs
+ (guile #f)
+ (outputs '("out"))
+ (configure-flags ''())
+ (search-paths '())
+ (native-search-paths '())
+ (make-flags ''())
+ (out-of-source? #t)
+ (build-type "RelWithDebInfo")
+ (tests? #f) ; nothing can be done
+ (test-target "test")
+ (parallel-build? #t) (parallel-tests? #f)
+ (validate-runpath? #t)
+ (patch-shebangs? #t)
+ (strip-binaries? #t)
+ (strip-flags ''("--strip-debug"
+ "--enable-deterministic-archives"))
+ (strip-directories ''("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ (phases '(@ (guix build qt-build-system)
%standard-phases))
- (system (%current-system))
- (build (nix-system->gnu-triplet system))
- (imported-modules %qt-build-system-modules)
- (modules '((guix build cmake-build-system)
- (guix build utils))))
+ (system (%current-system))
+ (build (nix-system->gnu-triplet system))
+ (imported-modules %qt-build-system-modules)
+ (modules '((guix build qt-build-system)
+ (guix build utils))))
"Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and
with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its
build system."
@@ -237,38 +237,38 @@ build system."
`(,name . ,path)))
target-drvs))
- (cmake-build #:source ,(match (assoc-ref native-drvs "source")
- (((? derivation? source))
- (derivation->output-path source))
- ((source)
- source)
- (source
- source))
- #:system ,system
- #:build ,build
- #:target ,target
- #:outputs %outputs
- #:inputs %build-target-inputs
- #:native-inputs %build-host-inputs
- #:search-paths ',(map search-path-specification->sexp
- search-paths)
- #:native-search-paths ',(map
- search-path-specification->sexp
- native-search-paths)
- #:phases ,phases
- #:configure-flags ,configure-flags
- #:make-flags ,make-flags
- #:out-of-source? ,out-of-source?
- #:build-type ,build-type
- #:tests? ,tests?
- #:test-target ,test-target
- #:parallel-build? ,parallel-build?
- #:parallel-tests? ,parallel-tests?
- #:validate-runpath? ,validate-runpath?
- #:patch-shebangs? ,patch-shebangs?
- #:strip-binaries? ,strip-binaries?
- #:strip-flags ,strip-flags
- #:strip-directories ,strip-directories))))
+ (qt-build #:source ,(match (assoc-ref native-drvs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:build ,build
+ #:target ,target
+ #:outputs %outputs
+ #:inputs %build-target-inputs
+ #:native-inputs %build-host-inputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:native-search-paths ',(map
+ search-path-specification->sexp
+ native-search-paths)
+ #:phases ,phases
+ #:configure-flags ,configure-flags
+ #:make-flags ,make-flags
+ #:out-of-source? ,out-of-source?
+ #:build-type ,build-type
+ #:tests? ,tests?
+ #:test-target ,test-target
+ #:parallel-build? ,parallel-build?
+ #:parallel-tests? ,parallel-tests?
+ #:validate-runpath? ,validate-runpath?
+ #:patch-shebangs? ,patch-shebangs?
+ #:strip-binaries? ,strip-binaries?
+ #:strip-flags ,strip-flags
+ #:strip-directories ,strip-directories))))
(define guile-for-build
(match guile
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
index dd2a9fe8de..2d328764b0 100644
--- a/guix/build-system/r.scm
+++ b/guix/build-system/r.scm
@@ -59,7 +59,7 @@ release corresponding to NAME and VERSION."
"/src/contrib/"
name "_" version ".tar.gz")
;; TODO: use %bioconductor-version from (guix import cran)
- (string-append "https://bioconductor.org/packages/3.9"
+ (string-append "https://bioconductor.org/packages/3.10"
type-url-part
"/src/contrib/Archive/"
name "_" version ".tar.gz"))))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 141ef409d6..53a144f126 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -158,7 +158,7 @@ out if the connection could not be established in less than TIMEOUT seconds."
;; See <http://bugs.gnu.org/12202>.
(module-autoload! (current-module)
'(gnutls)
- '(gnutls-version make-session connection-end/client))
+ '(make-session connection-end/client))
(define %tls-ports
;; Mapping of session record ports to the underlying file port.
@@ -273,18 +273,7 @@ host name without trailing dot."
;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
;; Explicitly disable SSLv3, which is insecure:
;; <https://tools.ietf.org/html/rfc7568>.
- ;;
- ;; FIXME: Since we currently fail to handle TLS 1.3 (with GnuTLS 3.6.5),
- ;; remove it; see <https://bugs.gnu.org/34102>.
- (set-session-priorities! session
- (string-append
- "NORMAL:%COMPAT:-VERS-SSL3.0"
-
- ;; The "VERS-TLS1.3" priority string is not
- ;; supported by GnuTLS 3.5.
- (if (string-prefix? "3.5." (gnutls-version))
- ""
- ":-VERS-TLS1.3")))
+ (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")
(set-session-credentials! session
(if (and verify-certificate? ca-certs)
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 52c1ea177e..09de244993 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -76,8 +76,18 @@ archive, a directory, or an Emacs Lisp file."
(define* (add-source-to-load-path #:key dummy #:allow-other-keys)
"Augment the EMACSLOADPATH environment variable with the source directory."
(let* ((source-directory (getcwd))
- (emacs-load-path-value (string-append source-directory ":"
- (getenv "EMACSLOADPATH"))))
+ (emacs-load-path (string-split (getenv "EMACSLOADPATH") #\:))
+ ;; XXX: Make sure the Emacs core libraries appear at the end of
+ ;; EMACSLOADPATH, to avoid shadowing any other libraries depended
+ ;; upon.
+ (emacs-load-path-non-core (filter (cut string-contains <>
+ "/share/emacs/site-lisp")
+ emacs-load-path))
+ (emacs-load-path-value (string-append
+ (string-join (cons source-directory
+ emacs-load-path-non-core)
+ ":")
+ ":")))
(setenv "EMACSLOADPATH" emacs-load-path-value)
(format #t "source directory ~s prepended to the `EMACSLOADPATH' \
environment variable\n" source-directory)))
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm
index fdacd30dd6..885fd0a217 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2019 Leo Prikler <leo.prikler@student.tugraz.at>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +24,7 @@
#:export (%emacs
emacs-batch-eval
emacs-batch-edit-file
+ emacs-batch-disable-compilation
emacs-generate-autoloads
emacs-byte-compile-directory
emacs-substitute-sexps
@@ -50,6 +52,12 @@
(string-append "--visit=" file)
(format #f "--eval=~S" expr)))
+(define (emacs-batch-disable-compilation file)
+ (emacs-batch-edit-file file
+ '(progn
+ (add-file-local-variable 'no-byte-compile t)
+ (basic-save-buffer))))
+
(define (emacs-generate-autoloads name directory)
"Generate autoloads for Emacs package NAME placed in DIRECTORY."
(let* ((file (string-append directory "/" name "-autoloads.el"))
diff --git a/guix/describe.scm b/guix/describe.scm
index 893dca2640..6b9b219113 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -30,7 +30,8 @@
current-profile-entries
package-path-entries
- package-provenance))
+ package-provenance
+ manifest-entry-with-provenance))
;;; Commentary:
;;;
@@ -144,3 +145,18 @@ property of manifest entries, or #f if it could not be determined."
(and main
`(,main
,@(if extra (list extra) '()))))))))))
+
+(define (manifest-entry-with-provenance entry)
+ "Return ENTRY with an additional 'provenance' property if it's not already
+there."
+ (let ((properties (manifest-entry-properties entry)))
+ (if (assq 'properties properties)
+ entry
+ (let ((item (manifest-entry-item entry)))
+ (manifest-entry
+ (inherit entry)
+ (properties
+ (match (and (package? item) (package-provenance item))
+ (#f properties)
+ (sexp `((provenance ,@sexp)
+ ,@properties)))))))))
diff --git a/guix/download.scm b/guix/download.scm
index 47c8087732..b6b4812fa7 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -132,7 +132,6 @@
"ftp://ftp.hu.netfilter.org/"
"ftp://www.lt.netfilter.org/pub/")
(kernel.org
- "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/"
"http://linux-kernel.uio.no/pub/"
"http://kernel.osuosl.org/pub/"
"http://ftp.be.debian.org/pub/"
diff --git a/guix/gexp.scm b/guix/gexp.scm
index ef09c030ee..cacc2bf183 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1032,7 +1032,7 @@ and in the current monad setting (system type, etc.)"
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? keyword? pair? null? array?
- number? boolean?)))
+ number? boolean? char?)))
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
diff --git a/guix/git.scm b/guix/git.scm
index d7dddde3a7..83af596ef5 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -347,10 +347,11 @@ Log progress and checkout info to LOG-PORT."
;;; Commit difference.
;;;
-(define (commit-closure commit)
- "Return the closure of COMMIT as a set."
+(define* (commit-closure commit #:optional (visited (setq)))
+ "Return the closure of COMMIT as a set. Skip commits contained in VISITED,
+a set, and adjoin VISITED to the result."
(let loop ((commits (list commit))
- (visited (setq)))
+ (visited visited))
(match commits
(()
visited)
@@ -360,15 +361,16 @@ Log progress and checkout info to LOG-PORT."
(loop (append (commit-parents head) tail)
(set-insert head visited)))))))
-(define (commit-difference new old)
+(define* (commit-difference new old #:optional (excluded '()))
"Return the list of commits between NEW and OLD, where OLD is assumed to be
-an ancestor of NEW.
+an ancestor of NEW. Exclude all the commits listed in EXCLUDED along with
+their ancestors.
Essentially, this computes the set difference between the closure of NEW and
that of OLD."
(let loop ((commits (list new))
(result '())
- (visited (commit-closure old)))
+ (visited (commit-closure old (list->setq excluded))))
(match commits
(()
(reverse result))
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
index 40feb44561..bf0283f8fe 100644
--- a/guix/gnupg.scm
+++ b/guix/gnupg.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
@@ -59,28 +59,37 @@
;; unreliable.
(make-parameter "pool.sks-keyservers.net"))
+;; Regexps for status lines. See file `doc/DETAILS' in GnuPG.
+
+(define sigid-rx
+ (make-regexp
+ "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
+(define goodsig-rx
+ (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
+(define validsig-rx
+ (make-regexp
+ "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
+(define expkeysig-rx ; good signature, but expired key
+ (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
+(define errsig-rx
+ ;; Note: The fingeprint part (the last element of the line) appeared in
+ ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
+ (make-regexp
+ "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
+
+
(define* (gnupg-verify sig file
#:optional (keyring (current-keyring)))
"Verify signature SIG for FILE against the keys in KEYRING. All the keys in
KEYRING as assumed to be \"trusted\", whether or not they expired or were
revoked. Return a status s-exp if GnuPG failed."
- (define (status-line->sexp line)
- ;; See file `doc/DETAILS' in GnuPG.
- (define sigid-rx
- (make-regexp
- "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
- (define goodsig-rx
- (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
- (define validsig-rx
- (make-regexp
- "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
- (define expkeysig-rx ; good signature, but expired key
- (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
- (define errsig-rx
- (make-regexp
- "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
+ (define (maybe-fingerprint str)
+ (match (string-trim-both str)
+ ((or "-" "") #f)
+ (fpr fpr)))
+ (define (status-line->sexp line)
(cond ((regexp-exec sigid-rx line)
=>
(lambda (match)
@@ -108,7 +117,7 @@ revoked. Return a status s-exp if GnuPG failed."
((regexp-exec errsig-rx line)
=>
(lambda (match)
- `(signature-error ,(match:substring match 1) ; key id or fingerprint
+ `(signature-error ,(match:substring match 1) ; key id
,(match:substring match 2) ; pubkey algo
,(match:substring match 3) ; hash algo
,(match:substring match 4) ; sig class
@@ -120,7 +129,9 @@ revoked. Return a status s-exp if GnuPG failed."
(case rc
((9) 'missing-key)
((4) 'unknown-algorithm)
- (else rc))))))
+ (else rc)))
+ ,(maybe-fingerprint ; fingerprint or #f
+ (match:substring match 7)))))
(else
`(unparsed-line ,line))))
@@ -142,33 +153,37 @@ revoked. Return a status s-exp if GnuPG failed."
(define (gnupg-status-good-signature? status)
"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
-a key-id/user pair; return #f otherwise."
- (any (lambda (sexp)
- (match sexp
- (((or 'good-signature 'expired-key-signature) key-id user)
- (cons key-id user))
- (_ #f)))
- status))
+a fingerprint/user pair; return #f otherwise."
+ (match (assq 'valid-signature status)
+ (('valid-signature fingerprint date timestamp)
+ (match (or (assq 'good-signature status)
+ (assq 'expired-key-signature status))
+ ((_ key-id user) (cons fingerprint user))
+ (_ #f)))
+ (_
+ #f)))
(define (gnupg-status-missing-key? status)
- "If STATUS denotes a missing-key error, then return the key-id of the
-missing key."
+ "If STATUS denotes a missing-key error, then return the fingerprint of the
+missing key or its key id if the fingerprint is unavailable."
(any (lambda (sexp)
(match sexp
- (('signature-error key-id _ ...)
- key-id)
+ (('signature-error key-id _ ... 'missing-key fingerprint)
+ (or fingerprint key-id))
(_ #f)))
status))
-(define* (gnupg-receive-keys key-id server
+(define* (gnupg-receive-keys fingerprint/key-id server
#:optional (keyring (current-keyring)))
+ "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to
+KEYRING."
(unless (file-exists? keyring)
(mkdir-p (dirname keyring))
(call-with-output-file keyring (const #t))) ;create an empty keybox
- (system* (%gpg-command) "--keyserver" server
- "--no-default-keyring" "--keyring" keyring
- "--recv-keys" key-id))
+ (zero? (system* (%gpg-command) "--keyserver" server
+ "--no-default-keyring" "--keyring" keyring
+ "--recv-keys" fingerprint/key-id)))
(define* (gnupg-verify* sig file
#:key
@@ -176,35 +191,48 @@ missing key."
(server (%openpgp-key-server))
(keyring (current-keyring)))
"Like `gnupg-verify', but try downloading the public key if it's missing.
-Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
-download policy for missing OpenPGP keys; allowed values: 'always', 'never',
-and 'interactive' (default)."
+Return two values: 'valid-signature and a fingerprint/name pair upon success,
+'missing-key and a fingerprint if the key could not be found, and
+'invalid-signature with a fingerprint if the signature is invalid.
+
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'always', 'never', and 'interactive' (default). Return a
+fingerprint/user name pair on success and #f otherwise."
(let ((status (gnupg-verify sig file)))
- (or (gnupg-status-good-signature? status)
- (let ((missing (gnupg-status-missing-key? status)))
- (define (download-and-try-again)
- ;; Download the missing key and try again.
- (begin
- (gnupg-receive-keys missing server keyring)
- (gnupg-status-good-signature? (gnupg-verify sig file
- keyring))))
-
- (define (receive?)
- (let ((answer
- (begin
- (format #t (G_ "Would you like to add this key \
+ (match (gnupg-status-good-signature? status)
+ ((fingerprint . user)
+ (values 'valid-signature (cons fingerprint user)))
+ (#f
+ (let ((missing (gnupg-status-missing-key? status)))
+ (define (download-and-try-again)
+ ;; Download the missing key and try again.
+ (if (gnupg-receive-keys missing server keyring)
+ (match (gnupg-status-good-signature?
+ (gnupg-verify sig file keyring))
+ (#f
+ (values 'invalid-signature missing))
+ ((fingerprint . user)
+ (values 'valid-signature
+ (cons fingerprint user))))
+ (values 'missing-key missing)))
+
+ (define (receive?)
+ (let ((answer
+ (begin
+ (format #t (G_ "Would you like to add this key \
to keyring '~a'?~%")
- keyring)
- (read-line))))
- (string-match (locale-yes-regexp) answer)))
-
- (and missing
- (case key-download
- ((never) #f)
- ((always)
- (download-and-try-again))
- (else
- (and (receive?)
- (download-and-try-again)))))))))
+ keyring)
+ (read-line))))
+ (string-match (locale-yes-regexp) answer)))
+
+ (case key-download
+ ((never)
+ (values 'missing-key missing))
+ ((always)
+ (download-and-try-again))
+ (else
+ (if (receive?)
+ (download-and-try-again)
+ (values 'missing-key missing)))))))))
;;; gnupg.scm ends here
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index d9018cc7da..f3f1747e43 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -82,6 +82,7 @@
("LGPL-2.1" 'lgpl2.1)
("LGPL-3" 'lgpl3)
("LGPL (>= 2)" 'lgpl2.0+)
+ ("LGPL (>= 2.1)" 'lgpl2.1+)
("LGPL (>= 3)" 'lgpl3+)
("MIT" 'expat)
("MIT + file LICENSE" 'expat)
@@ -132,9 +133,9 @@ package definition."
(define %cran-url "https://cran.r-project.org/web/packages/")
(define %bioconductor-url "https://bioconductor.org/packages/")
-;; The latest Bioconductor release is 3.9. Bioconductor packages should be
+;; The latest Bioconductor release is 3.10. Bioconductor packages should be
;; updated together.
-(define %bioconductor-version "3.9")
+(define %bioconductor-version "3.10")
(define* (bioconductor-packages-list-url #:optional type)
(string-append "https://bioconductor.org/packages/"
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 47fc8276a9..d17d400ddf 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -402,7 +402,7 @@ obtain a node's uniquely identifying \"key\"."
(define* (recursive-import package-name repo
#:key repo->guix-package guix-name
#:allow-other-keys)
- "Return a stream of package expressions for PACKAGE-NAME and all its
+ "Return a list of package expressions for PACKAGE-NAME and all its
dependencies, sorted in topological order. For each package,
call (REPO->GUIX-PACKAGE NAME REPO), which should return a package expression
and a list of dependencies; call (GUIX-NAME NAME) to obtain the Guix package
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 71dae89e92..c4969cd56a 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -82,6 +82,7 @@
inferior-package-native-search-paths
inferior-package-transitive-native-search-paths
inferior-package-search-paths
+ inferior-package-provenance
inferior-package-derivation
inferior-package->manifest-entry
@@ -416,6 +417,19 @@ package."
(define inferior-package-transitive-native-search-paths
(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
+(define (inferior-package-provenance package)
+ "Return a \"provenance sexp\" for PACKAGE, an inferior package. The result
+is similar to the sexp returned by 'package-provenance' for regular packages."
+ (inferior-package-field package
+ '(let* ((describe
+ (false-if-exception
+ (resolve-interface '(guix describe))))
+ (provenance
+ (false-if-exception
+ (module-ref describe
+ 'package-provenance))))
+ (or provenance (const #f)))))
+
(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
diff --git a/guix/packages.scm b/guix/packages.scm
index c98fb98aec..5ecb97f946 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -3,7 +3,7 @@
;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -236,7 +236,7 @@ name of its URI."
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
- '("i585-gnu" "i686-gnu"))
+ '("i586-gnu" "i686-gnu"))
(define %hydra-supported-systems
;; This is the list of system types for which build machines are available.
diff --git a/guix/profiles.scm b/guix/profiles.scm
index d20f06e7b3..93ceafc4bc 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -94,6 +94,7 @@
manifest-pattern-output
concatenate-manifests
+ map-manifest-entries
manifest-remove
manifest-add
manifest-lookup
@@ -521,6 +522,11 @@ procedure is here for backward-compatibility and will eventually vanish."
"Concatenate the manifests listed in LST and return the resulting manifest."
(manifest (append-map manifest-entries lst)))
+(define (map-manifest-entries proc manifest)
+ "Apply PROC to all the entries of MANIFEST and return a new manifest."
+ (make-manifest
+ (map proc (manifest-entries manifest))))
+
(define (entry-predicate pattern)
"Return a procedure that returns #t when passed a manifest entry that
matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
diff --git a/guix/progress.scm b/guix/progress.scm
index 349637dbcf..c7567a35fd 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -40,6 +40,7 @@
progress-reporter/file
progress-reporter/bar
progress-reporter/trace
+ progress-report-port
display-download-progress
erase-current-line
@@ -342,3 +343,33 @@ should be a <progress-reporter> object."
(put-bytevector out buffer 0 bytes)
(report total)
(loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
+
+(define (progress-report-port reporter port)
+ "Return a port that continuously reports the bytes read from PORT using
+REPORTER, which should be a <progress-reporter> object."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (let* ((total 0)
+ (read! (lambda (bv start count)
+ (let ((n (match (get-bytevector-n! port bv start count)
+ ((? eof-object?) 0)
+ (x x))))
+ (set! total (+ total n))
+ (report total)
+ n))))
+ (start)
+ (make-custom-binary-input-port "progress-port-proc"
+ read! #f #f
+ (lambda ()
+ ;; XXX: Kludge! When used through
+ ;; 'decompressed-port', this port ends
+ ;; up being closed twice: once in a
+ ;; child process early on, and at the
+ ;; end in the parent process. Ignore
+ ;; the early close so we don't output
+ ;; a spurious "download-succeeded"
+ ;; trace.
+ (unless (zero? total)
+ (stop))
+ (close-port port)))))))
+
diff --git a/guix/repl.scm b/guix/repl.scm
index 1ead18c53b..0f75f9cd0b 100644
--- a/guix/repl.scm
+++ b/guix/repl.scm
@@ -37,7 +37,7 @@
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? keyword? pair? null? array?
- number? boolean?)))
+ number? boolean? char?)))
(define (send-repl-response exp output)
"Write the response corresponding to the evaluation of EXP to PORT, an
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 3318ef0889..2b4d39c7b8 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -21,7 +21,8 @@
#:use-module (guix utils)
#:use-module (guix combinators)
#:use-module ((guix build utils) #:select (mkdir-p))
- #:use-module ((guix serialization) #:select (restore-file))
+ #:use-module ((guix serialization)
+ #:select (fold-archive restore-file))
#:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
@@ -43,6 +44,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
#:export (guix-archive
options->derivations+files))
@@ -76,6 +78,8 @@ Export/import one or more packages from/to the store.\n"))
--missing print the files from stdin that are missing"))
(display (G_ "
-x, --extract=DIR extract the archive on stdin to DIR"))
+ (display (G_ "
+ -t, --list list the files in the archive on stdin"))
(newline)
(display (G_ "
--generate-key[=PARAMETERS]
@@ -137,6 +141,9 @@ Export/import one or more packages from/to the store.\n"))
(option '("extract" #\x) #t #f
(lambda (opt name arg result)
(alist-cons 'extract arg result)))
+ (option '("list" #\t) #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'list #t result)))
(option '("generate-key") #f #t
(lambda (opt name arg result)
(catch 'gcry-error
@@ -319,6 +326,40 @@ the input port."
(with-atomic-file-output %acl-file
(cut write-acl acl <>)))))
+(define (list-contents port)
+ "Read a nar from PORT and print the list of files it contains to the current
+output port."
+ (define (consume-input port size)
+ (let ((bv (make-bytevector 32768)))
+ (let loop ((total size))
+ (unless (zero? total)
+ (let ((n (get-bytevector-n! port bv 0
+ (min total (bytevector-length bv)))))
+ (loop (- total n)))))))
+
+ (fold-archive (lambda (file type content result)
+ (match type
+ ('directory
+ (format #t "D ~a~%" file))
+ ('symlink
+ (format #t "S ~a -> ~a~%" file content))
+ ((or 'regular 'executable)
+ (match content
+ ((input . size)
+ (format #t "~a ~60a ~10h B~%"
+ (if (eq? type 'executable)
+ "x" "r")
+ file size)
+ (consume-input input size))))))
+ #t
+ port
+ ""))
+
+
+;;;
+;;; Entry point.
+;;;
+
(define (guix-archive . args)
(define (lines port)
;; Return lines read from PORT.
@@ -353,6 +394,8 @@ the input port."
(missing (remove (cut valid-path? store <>)
files)))
(format #t "~{~a~%~}" missing)))
+ ((assoc-ref opts 'list)
+ (list-contents (current-input-port)))
((assoc-ref opts 'extract)
=>
(lambda (target)
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 17e87f0291..ebeebd5cbe 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -25,17 +25,23 @@
#:use-module (guix monads)
#:use-module (guix base32)
#:use-module (guix packages)
+ #:use-module (guix progress)
#:use-module (guix serialization)
#:use-module (guix scripts substitute)
#:use-module (rnrs bytevectors)
+ #:autoload (guix http-client) (http-fetch)
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module (gcrypt hash)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
#:use-module (web uri)
#:export (compare-contents
@@ -49,6 +55,9 @@
comparison-report-mismatch?
comparison-report-inconclusive?
+ differing-files
+ call-with-mismatches
+
guix-challenge))
;;; Commentary:
@@ -179,20 +188,193 @@ taken since we do not import the archives."
items
local))))
+
+;;;
+;;; Reporting.
+;;;
+
+(define dump-port* ;FIXME: deduplicate
+ (@@ (guix serialization) dump))
+
+(define (port-sha256* port size)
+ ;; Like 'port-sha256', but limited to SIZE bytes.
+ (let-values (((out get) (open-sha256-port)))
+ (dump-port* port out size)
+ (close-port out)
+ (get)))
+
+(define (archive-contents port)
+ "Return a list representing the files contained in the nar read from PORT."
+ (fold-archive (lambda (file type contents result)
+ (match type
+ ((or 'regular 'executable)
+ (match contents
+ ((port . size)
+ (cons `(,file ,type ,(port-sha256* port size))
+ result))))
+ ('directory result)
+ ('symlink
+ (cons `(,file ,type ,contents) result))))
+ '()
+ port
+ ""))
+
+(define (store-item-contents item)
+ "Return a list of files and contents for ITEM in the same format as
+'archive-contents'."
+ (file-system-fold (const #t) ;enter?
+ (lambda (file stat result) ;leaf
+ (define short
+ (string-drop file (string-length item)))
+
+ (match (stat:type stat)
+ ('regular
+ (let ((size (stat:size stat))
+ (type (if (zero? (logand (stat:mode stat)
+ #o100))
+ 'regular
+ 'executable)))
+ (cons `(,short ,type
+ ,(call-with-input-file file
+ (cut port-sha256* <> size)))
+ result)))
+ ('symlink
+ (cons `(,short symlink ,(readlink file))
+ result))))
+ (lambda (directory stat result) result) ;down
+ (lambda (directory stat result) result) ;up
+ (lambda (file stat result) result) ;skip
+ (lambda (file stat errno result) result) ;error
+ '()
+ item
+ lstat))
+
+(define (call-with-nar narinfo proc)
+ "Call PROC with an input port from which it can read the nar pointed to by
+NARINFO."
+ (let*-values (((uri compression size)
+ (narinfo-best-uri narinfo))
+ ((port response)
+ (http-fetch uri)))
+ (define reporter
+ (progress-reporter/file (narinfo-path narinfo) size
+ #:abbreviation (const (uri-host uri))))
+
+ (define result
+ (call-with-decompressed-port (string->symbol compression)
+ (progress-report-port reporter port)
+ proc))
+
+ (close-port port)
+ (erase-current-line (current-output-port))
+ result))
+
+(define (narinfo-contents narinfo)
+ "Fetch the nar described by NARINFO and return a list representing the file
+it contains."
+ (call-with-nar narinfo archive-contents))
+
+(define (differing-files comparison-report)
+ "Return a list of files that differ among the nars and possibly the local
+store item specified in COMPARISON-REPORT."
+ (define contents
+ (map narinfo-contents
+ (comparison-report-narinfos comparison-report)))
+
+ (define local-contents
+ (and (comparison-report-local-sha256 comparison-report)
+ (store-item-contents (comparison-report-item comparison-report))))
+
+ (match (apply lset-difference equal?
+ (take (delete-duplicates
+ (if local-contents
+ (cons local-contents contents)
+ contents))
+ 2))
+ (((files _ ...) ...)
+ files)))
+
+(define (report-differing-files comparison-report)
+ "Report differences among the nars and possibly the local store item
+specified in COMPARISON-REPORT."
+ (match (differing-files comparison-report)
+ (()
+ #t)
+ ((files ...)
+ (format #t (N_ " differing file:~%"
+ " differing files:~%"
+ (length files)))
+ (format #t "~{ ~a~%~}" files))))
+
+(define (call-with-mismatches comparison-report proc)
+ "Call PROC with two directories containing the mismatching store items."
+ (define local-hash
+ (comparison-report-local-sha256 comparison-report))
+
+ (define narinfos
+ (comparison-report-narinfos comparison-report))
+
+ (call-with-temporary-directory
+ (lambda (directory1)
+ (call-with-temporary-directory
+ (lambda (directory2)
+ (define narinfo1
+ (if local-hash
+ (find (lambda (narinfo)
+ (not (bytevector=? (narinfo-hash->sha256
+ (narinfo-hash narinfo))
+ local-hash)))
+ narinfos)
+ (first (comparison-report-narinfos comparison-report))))
+
+ (define narinfo2
+ (and (not local-hash)
+ (find (lambda (narinfo)
+ (not (eq? narinfo narinfo1)))
+ narinfos)))
+
+ (rmdir directory1)
+ (call-with-nar narinfo1 (cut restore-file <> directory1))
+ (when narinfo2
+ (rmdir directory2)
+ (call-with-nar narinfo2 (cut restore-file <> directory2)))
+ (proc directory1
+ (if local-hash
+ (comparison-report-item comparison-report)
+ directory2)))))))
+
+(define %diffoscope-command
+ ;; Default external diff command. Pass "--exclude-directory-metadata" so
+ ;; that the mtime/ctime differences are ignored.
+ '("diffoscope" "--exclude-directory-metadata=yes"))
+
+(define* (report-differing-files/external comparison-report
+ #:optional
+ (command %diffoscope-command))
+ "Run COMMAND to show the file-level differences for the mismatches in
+COMPARISON-REPORT."
+ (call-with-mismatches comparison-report
+ (lambda (directory1 directory2)
+ (apply system*
+ (append command
+ (list directory1 directory2))))))
+
(define* (summarize-report comparison-report
#:key
+ (report-differences (const #f))
(hash->string bytevector->nix-base32-string)
verbose?)
- "Write to the current error port a summary of REPORT, a <comparison-report>
-object. When VERBOSE?, display matches in addition to mismatches and
-inconclusive reports."
+ "Write to the current error port a summary of COMPARISON-REPORT, a
+<comparison-report> object. When VERBOSE?, display matches in addition to
+mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES
+with COMPARISON-REPORT."
(define (report-hashes item local narinfos)
(if local
(report (G_ " local hash: ~a~%") (hash->string local))
(report (G_ " no local build for '~a'~%") item))
(for-each (lambda (narinfo)
(report (G_ " ~50a: ~a~%")
- (uri->string (first (narinfo-uris narinfo)))
+ (uri->string (narinfo-best-uri narinfo))
(hash->string
(narinfo-hash->sha256 (narinfo-hash narinfo)))))
narinfos))
@@ -200,7 +382,8 @@ inconclusive reports."
(match comparison-report
(($ <comparison-report> item 'mismatch local (narinfos ...))
(report (G_ "~a contents differ:~%") item)
- (report-hashes item local narinfos))
+ (report-hashes item local narinfos)
+ (report-differences comparison-report))
(($ <comparison-report> item 'inconclusive #f narinfos)
(warning (G_ "could not challenge '~a': no local build~%") item))
(($ <comparison-report> item 'inconclusive locals ())
@@ -237,6 +420,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
compare build results with those at URLS"))
(display (G_ "
-v, --verbose show details about successful comparisons"))
+ (display (G_ "
+ --diff=MODE show differences according to MODE"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
@@ -254,6 +439,22 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(lambda args
(show-version-and-exit "guix challenge")))
+ (option '("diff") #t #f
+ (lambda (opt name arg result . rest)
+ (define mode
+ (match arg
+ ("none" (const #t))
+ ("simple" report-differing-files)
+ ("diffoscope" report-differing-files/external)
+ ((and (? (cut string-prefix? "/" <>)) command)
+ (cute report-differing-files/external <>
+ (string-tokenize command)))
+ (_ (leave (G_ "~a: unknown diff mode~%") arg))))
+
+ (apply values
+ (alist-cons 'difference-report mode result)
+ rest)))
+
(option '("substitute-urls") #t #f
(lambda (opt name arg result . rest)
(apply values
@@ -269,7 +470,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(define %default-options
`((system . ,(%current-system))
- (substitute-urls . ,%default-substitute-urls)))
+ (substitute-urls . ,%default-substitute-urls)
+ (difference-report . ,report-differing-files)))
;;;
@@ -286,12 +488,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
opts))
(system (assoc-ref opts 'system))
(urls (assoc-ref opts 'substitute-urls))
+ (diff (assoc-ref opts 'difference-report))
(verbose? (assoc-ref opts 'verbose?)))
(leave-on-EPIPE
(with-store store
;; Disable grafts since substitute servers normally provide only
;; ungrafted stuff.
- (parameterize ((%graft? #f))
+ (parameterize ((%graft? #f)
+ (current-terminal-columns (terminal-columns)))
(let ((files (match files
(()
(filter (cut locally-built? store <>)
@@ -305,7 +509,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(mlet* %store-monad ((items (mapm %store-monad
ensure-store-item files))
(reports (compare-contents items urls)))
- (for-each (cut summarize-report <> #:verbose? verbose?)
+ (for-each (cut summarize-report <> #:verbose? verbose?
+ #:report-differences diff)
reports)
(report "\n")
(summarize-report-list reports)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index bbacc93bc0..b84e37cbf2 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -319,7 +319,7 @@ to the search paths of PROFILE."
entry-point
localstatedir?
(symlinks '())
- (archiver squashfs-tools-next))
+ (archiver squashfs-tools))
"Return a squashfs image containing a store initialized with the closure of
PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount
points for virtual file systems (like procfs), and optional symlinks.
@@ -753,11 +753,6 @@ last resort for relocation."
(manifest-entry-output entry)
args))))
-(define (map-manifest-entries proc manifest)
- "Apply PROC to all the entries of MANIFEST and return a new manifest."
- (make-manifest
- (map proc (manifest-entries manifest))))
-
;;;
;;; Command-line options.
@@ -979,36 +974,32 @@ Create a bundle of PACKAGE.\n"))
(('manifest . file) file)
(_ #f))
opts)))
- (define properties
+ (define with-provenance
(if (assoc-ref opts 'save-provenance?)
- (lambda (package)
- (match (package-provenance package)
- (#f
- (warning (G_ "could not determine provenance of package ~a~%")
- (package-full-name package))
- '())
- (sexp
- `((provenance . ,sexp)))))
- (const '())))
-
- (cond
- ((and (not (null? manifests)) (not (null? packages)))
- (leave (G_ "both a manifest and a package list were given~%")))
- ((not (null? manifests))
- (concatenate-manifests
- (map (lambda (file)
- (let ((user-module (make-user-module
- '((guix profiles) (gnu)))))
- (load* file user-module)))
- manifests)))
- (else
- (manifest
- (map (match-lambda
- ((package output)
- (package->manifest-entry package output
- #:properties
- (properties package))))
- packages))))))
+ (lambda (manifest)
+ (map-manifest-entries
+ (lambda (entry)
+ (let ((entry (manifest-entry-with-provenance entry)))
+ (unless (assq 'provenance (manifest-entry-properties entry))
+ (warning (G_ "could not determine provenance of package ~a~%")
+ (manifest-entry-name entry)))
+ entry))
+ manifest))
+ identity))
+
+ (with-provenance
+ (cond
+ ((and (not (null? manifests)) (not (null? packages)))
+ (leave (G_ "both a manifest and a package list were given~%")))
+ ((not (null? manifests))
+ (concatenate-manifests
+ (map (lambda (file)
+ (let ((user-module (make-user-module
+ '((guix profiles) (gnu)))))
+ (load* file user-module)))
+ manifests)))
+ (else
+ (packages->manifest packages))))))
(with-error-handling
(with-store store
@@ -1045,7 +1036,7 @@ Create a bundle of PACKAGE.\n"))
bootstrap-xz
(assoc-ref opts 'compressor)))
(archiver (if (equal? pack-format 'squashfs)
- squashfs-tools-next
+ squashfs-tools
(if bootstrap?
%bootstrap-coreutils&co
tar)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 92c6e34194..ea16435d2d 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -38,7 +38,7 @@
#:use-module (guix config)
#:use-module (guix scripts)
#:use-module (guix scripts build)
- #:autoload (guix describe) (package-provenance)
+ #:use-module (guix describe)
#:autoload (guix store roots) (gc-roots)
#:use-module ((guix build utils)
#:select (directory-exists? mkdir-p))
@@ -883,7 +883,10 @@ processed, #f otherwise."
opts))
(manifest (match files
(() (profile-manifest profile))
- (_ (concatenate-manifests (map load-manifest files)))))
+ (_ (map-manifest-entries
+ manifest-entry-with-provenance
+ (concatenate-manifests
+ (map load-manifest files))))))
(step1 (options->removable opts manifest
(manifest-transaction)))
(step2 (options->installable opts manifest step1))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b6034a75d2..7eca2c6874 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -80,6 +80,7 @@
narinfo-signature
narinfo-hash->sha256
+ narinfo-best-uri
lookup-narinfos
lookup-narinfos/diverse
@@ -822,35 +823,6 @@ was found."
(= (string-length file) 32)))))
(narinfo-cache-directories directory)))
-(define (progress-report-port reporter port)
- "Return a port that continuously reports the bytes read from PORT using
-REPORTER, which should be a <progress-reporter> object."
- (match reporter
- (($ <progress-reporter> start report stop)
- (let* ((total 0)
- (read! (lambda (bv start count)
- (let ((n (match (get-bytevector-n! port bv start count)
- ((? eof-object?) 0)
- (x x))))
- (set! total (+ total n))
- (report total)
- n))))
- (start)
- (make-custom-binary-input-port "progress-port-proc"
- read! #f #f
- (lambda ()
- ;; XXX: Kludge! When used through
- ;; 'decompressed-port', this port ends
- ;; up being closed twice: once in a
- ;; child process early on, and at the
- ;; end in the parent process. Ignore
- ;; the early close so we don't output
- ;; a spurious "download-succeeded"
- ;; trace.
- (unless (zero? total)
- (stop))
- (close-port port)))))))
-
(define-syntax with-networking
(syntax-rules ()
"Catch DNS lookup errors and TLS errors and gracefully exit."
@@ -913,7 +885,7 @@ expected by the daemon."
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo))
- (let-values (((uri compression file-size) (select-uri narinfo)))
+ (let-values (((uri compression file-size) (narinfo-best-uri narinfo)))
(format #t "~a\n~a\n"
(or file-size 0)
(or (narinfo-size narinfo) 0))))
@@ -967,7 +939,7 @@ this is a rough approximation."
(_ (or (string=? compression2 "none")
(string=? compression2 "gzip")))))
-(define (select-uri narinfo)
+(define (narinfo-best-uri narinfo)
"Select the \"best\" URI to download NARINFO's nar, and return three values:
the URI, its compression method (a string), and the compressed file size."
(define choices
@@ -1008,7 +980,7 @@ DESTINATION as a nar file. Verify the substitute against ACL."
store-item))
(let-values (((uri compression file-size)
- (select-uri narinfo)))
+ (narinfo-best-uri narinfo)))
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 3e9570753d..e69a3b6c97 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1189,6 +1189,11 @@ resulting from command-line parsing."
(define (process-command command args opts)
"Process COMMAND, one of the 'guix system' sub-commands. ARGS is its
argument list and OPTS is the option alist."
+ (define-syntax-rule (with-store* store exp ...)
+ (with-store store
+ (set-build-options-from-command-line store opts)
+ exp ...))
+
(case command
;; The following commands do not need to use the store, and they do not need
;; an operating system configuration file.
@@ -1213,22 +1218,20 @@ argument list and OPTS is the option alist."
(() #f)
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
- (with-store store
+ (with-store* store
(delete-matching-generations store %system-profile pattern)
(reinstall-bootloader store (generation-number %system-profile)))))
((switch-generation)
(let ((pattern (match args
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
- (with-store store
- (set-build-options-from-command-line store opts)
+ (with-store* store
(switch-to-system-generation store pattern))))
((roll-back)
(let ((pattern (match args
(() "")
(x (leave (G_ "wrong number of arguments~%"))))))
- (with-store store
- (set-build-options-from-command-line store opts)
+ (with-store* store
(roll-back-system store))))
;; The following commands need to use the store, and they also
;; need an operating system configuration file.
@@ -1297,6 +1300,7 @@ argument list and OPTS is the option alist."
;;; Local Variables:
;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
+;;; eval: (put 'with-store* 'scheme-indent-function 1)
;;; End:
;;; system.scm ends here
diff --git a/guix/serialization.scm b/guix/serialization.scm
index e14b7d1b9f..f793feb53d 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -48,6 +48,7 @@
write-file
write-file-tree
+ fold-archive
restore-file))
;;; Comment:
@@ -198,24 +199,6 @@ substitute invalid byte sequences with question marks. This is a
(put-bytevector out buf 0 read)
(loop (- left read))))))))
-(define (write-contents file p size)
- "Write SIZE bytes from FILE to output port P."
- (define (call-with-binary-input-file file proc)
- ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
- ;; avoids any initial buffering. Disable file name canonicalization to
- ;; avoid stat'ing like crazy.
- (with-fluids ((%file-port-name-canonicalization #f))
- (let ((port (open-file file "rb")))
- (dynamic-wind
- (const #t)
- (cut proc port)
- (lambda ()
- (close-port port))))))
-
- (call-with-binary-input-file file
- (lambda (input)
- (write-contents-from-port input p size))))
-
(define (write-contents-from-port input output size)
"Write SIZE bytes from port INPUT to port OUTPUT."
(write-string "contents" output)
@@ -226,38 +209,25 @@ substitute invalid byte sequences with question marks. This is a
(dump input output size))
(write-padding size output))
-(define (read-contents in out)
- "Read the contents of a file from the Nar at IN, write it to OUT, and return
-the size in bytes."
- (define executable?
- (match (read-string in)
- ("contents"
- #f)
- ("executable"
- (match (list (read-string in) (read-string in))
- (("" "contents") #t)
- (x (raise
- (condition (&message
- (message "unexpected executable file marker"))
- (&nar-read-error (port in)
- (file #f)
- (token x))))))
- #t)
- (x
- (raise
- (condition (&message (message "unsupported nar file type"))
- (&nar-read-error (port in) (file #f) (token x)))))))
-
- (let ((size (read-long-long in)))
- ;; Note: `sendfile' cannot be used here because of port buffering on IN.
- (dump in out size)
-
- (when executable?
- (chmod out #o755))
- (let ((m (modulo size 8)))
- (unless (zero? m)
- (get-bytevector-n* in (- 8 m))))
- size))
+(define (read-file-type port)
+ "Read the file type tag from PORT, and return either 'regular or
+'executable."
+ (match (read-string port)
+ ("contents"
+ 'regular)
+ ("executable"
+ (match (list (read-string port) (read-string port))
+ (("" "contents") 'executable)
+ (x (raise
+ (condition (&message
+ (message "unexpected executable file marker"))
+ (&nar-read-error (port port)
+ (file #f)
+ (token x)))))))
+ (x
+ (raise
+ (condition (&message (message "unsupported nar file type"))
+ (&nar-read-error (port port) (file #f) (token x)))))))
(define %archive-version-1
;; Magic cookie for Nix archives.
@@ -383,9 +353,14 @@ which case you can use 'identity'."
(define port-conversion-strategy
(fluid->parameter %default-port-conversion-strategy))
-(define (restore-file port file)
- "Read a file (possibly a directory structure) in Nar format from PORT.
-Restore it as FILE."
+(define (fold-archive proc seed port file)
+ "Read a file (possibly a directory structure) in Nar format from PORT. Call
+PROC on each file or directory read from PORT using:
+
+ (PROC FILE TYPE CONTENTS RESULT)
+
+using SEED as the first RESULT. TYPE is a symbol like 'regular, and CONTENTS
+depends on TYPE."
(parameterize ((currently-restored-file file)
;; Error out if we can convert file names to the current
@@ -401,7 +376,8 @@ Restore it as FILE."
(token signature)
(file #f))))))
- (let restore ((file file))
+ (let read ((file file)
+ (result seed))
(define (read-eof-marker)
(match (read-string port)
(")" #t)
@@ -414,40 +390,49 @@ Restore it as FILE."
(match (list (read-string port) (read-string port) (read-string port))
(("(" "type" "regular")
- (call-with-output-file file (cut read-contents port <>))
- (read-eof-marker))
+ (let* ((type (read-file-type port))
+ (size (read-long-long port))
+
+ ;; The caller must read exactly SIZE bytes from PORT.
+ (result (proc file type `(,port . ,size) result)))
+ (let ((m (modulo size 8)))
+ (unless (zero? m)
+ (get-bytevector-n* port (- 8 m))))
+ (read-eof-marker)
+ result))
(("(" "type" "symlink")
(match (list (read-string port) (read-string port))
(("target" target)
- (symlink target file)
- (read-eof-marker))
+ (let ((result (proc file 'symlink target result)))
+ (read-eof-marker)
+ result))
(x (raise
(condition
(&message (message "invalid symlink tokens"))
(&nar-read-error (port port) (file file) (token x)))))))
(("(" "type" "directory")
(let ((dir file))
- (mkdir dir)
- (let loop ((prefix (read-string port)))
+ (let loop ((prefix (read-string port))
+ (result (proc file 'directory #f result)))
(match prefix
("entry"
(match (list (read-string port)
(read-string port) (read-string port)
(read-string port))
(("(" "name" file "node")
- (restore (string-append dir "/" file))
- (match (read-string port)
- (")" #t)
- (x
- (raise
- (condition
- (&message
- (message "unexpected directory entry termination"))
- (&nar-read-error (port port)
- (file file)
- (token x))))))
- (loop (read-string port)))))
- (")" #t) ; done with DIR
+ (let ((result (read (string-append dir "/" file) result)))
+ (match (read-string port)
+ (")" #f)
+ (x
+ (raise
+ (condition
+ (&message
+ (message "unexpected directory entry termination"))
+ (&nar-read-error (port port)
+ (file file)
+ (token x))))))
+ (loop (read-string port) result)))))
+ (")" result) ;done with DIR
(x
(raise
(condition
@@ -459,6 +444,27 @@ Restore it as FILE."
(&message (message "unsupported nar entry type"))
(&nar-read-error (port port) (file file) (token x)))))))))
+(define (restore-file port file)
+ "Read a file (possibly a directory structure) in Nar format from PORT.
+Restore it as FILE."
+ (fold-archive (lambda (file type content result)
+ (match type
+ ('directory
+ (mkdir file))
+ ('symlink
+ (symlink content file))
+ ((or 'regular 'executable)
+ (match content
+ ((input . size)
+ (call-with-output-file file
+ (lambda (output)
+ (dump input output size)
+ (when (eq? type 'executable)
+ (chmod output #o755)))))))))
+ #t
+ port
+ file))
+
;;; Local Variables:
;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
;;; End:
diff --git a/guix/swh.scm b/guix/swh.scm
index 7acad05928..3abf9aa1b5 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -244,7 +244,7 @@ FALSE-IF-404? is true, return #f upon 404 responses."
docstring
(call (swh-url components ...) json->value)))))
-;; <https://archive.softwareheritage.org/api/1/origin/git/url/https://github.com/guix-mirror/guix/>
+;; <https://archive.softwareheritage.org/api/1/origin/https://github.com/guix-mirror/guix/get>
(define-json-mapping <origin> make-origin origin?
json->origin
(id origin-id)
@@ -365,7 +365,7 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(define-query (lookup-origin url)
"Return an origin for URL."
- (path "/api/1/origin/git/url" url)
+ (path "/api/1/origin" url "get")
json->origin)
(define-query (lookup-content hash type)
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 05ce39bca2..4119e9ce01 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -65,14 +65,14 @@ needed."
(close-port socket)
#t)))
-(define (%local-url)
+(define* (%local-url #:optional (port (%http-server-port)))
;; URL to use for 'home-page' tests.
- (string-append "http://localhost:" (number->string (%http-server-port))
+ (string-append "http://localhost:" (number->string port)
"/foo/bar"))
(define* (call-with-http-server responses+data thunk)
"Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
-requests. Each elements of RESPONSES+DATA must be a tuple containing a
+requests. Each element of RESPONSES+DATA must be a tuple containing a
response and a string, or an HTTP response code and a string."
(define responses
(map (match-lambda
diff --git a/guix/upstream.scm b/guix/upstream.scm
index aa47dab4b4..c11de0b25b 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -318,16 +318,20 @@ values: 'interactive' (default), 'always', and 'never'."
(basename url) tarball)))
(mbegin %store-monad
(built-derivations (list drv))
- (return (derivation->output-path drv)))))))
-
- (ret (gnupg-verify* sig data #:key-download key-download)))
- (if ret
- tarball
- (begin
- (warning (G_ "signature verification failed for `~a'~%")
- url)
- (warning (G_ "(could be because the public key is not in your keyring)~%"))
- #f))))))
+ (return (derivation->output-path drv))))))))
+ (let-values (((status data)
+ (gnupg-verify* sig data #:key-download key-download)))
+ (match status
+ ('valid-signature
+ tarball)
+ ('invalid-signature
+ (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
+ url data)
+ #f)
+ ('missing-key
+ (warning (G_ "missing public key ~a for '~a'~%")
+ data url)
+ #f)))))))
(define (find2 pred lst1 lst2)
"Like 'find', but operate on items from both LST1 and LST2. Return two
generated by cgit v1.2.3 (git 2.45.0) at 2025-02-06 05:55:53 +0000