From 12c1afcdbdc984c760d00932bce64288b385bbc9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Dec 2019 22:05:31 +0100 Subject: serialization: Add 'fold-archive'. * guix/serialization.scm (read-contents): Remove. (read-file-type, fold-archive): New procedures. (restore-file): Rewrite in terms of 'fold-archive'. * tests/nar.scm ("write-file-tree + fold-archive") ("write-file-tree + fold-archive, flat file"): New tests. --- guix/serialization.scm | 134 +++++++++++++++++++++++++++++-------------------- 1 file changed, 79 insertions(+), 55 deletions(-) (limited to 'guix') diff --git a/guix/serialization.scm b/guix/serialization.scm index e14b7d1b9f..cf263d321e 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -48,6 +48,7 @@ write-file write-file-tree + fold-archive restore-file)) ;;; Comment: @@ -226,38 +227,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 +371,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 +394,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 +408,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 +462,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: -- cgit v1.2.3 From 044277f610b02c3821afa0afdc2b2b140bb92cb4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Dec 2019 22:54:05 +0100 Subject: guix archive: Add '--list'. * guix/scripts/archive.scm (show-help, %options): Add '--list'. (list-contents): New procedure. (guix-archive): Honor the '--list' option. * tests/guix-archive.sh: Test it. * doc/guix.texi (Invoking guix archive): Document it. --- doc/guix.texi | 12 ++++++++++++ guix/scripts/archive.scm | 45 ++++++++++++++++++++++++++++++++++++++++++++- tests/guix-archive.sh | 7 ++++++- 3 files changed, 62 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 01980bf2d3..cb51878004 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4598,6 +4598,18 @@ unsafe. The primary purpose of this operation is to facilitate inspection of archive contents coming from possibly untrusted substitute servers. +@item --list +@itemx -t +Read a single-item archive as served by substitute servers +(@pxref{Substitutes}) and print the list of files it contains, as in +this example: + +@example +$ wget -O - \ + https://@value{SUBSTITUTE-SERVER}/nar/lzip/@dots{}-emacs-26.3 \ + | lzip -d | guix archive -t +@end example + @end table 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/tests/guix-archive.sh b/tests/guix-archive.sh index fdaeb98ad2..4c5eea05cf 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2014, 2015 Ludovic Courtès +# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -74,5 +74,10 @@ guix archive -x "$tmpdir" < "$archive" test -x "$tmpdir/bin/guile" test -d "$tmpdir/lib/guile" +# Check '--list'. +guix archive -t < "$archive" | grep "^D /share/guile" +guix archive -t < "$archive" | grep "^x /bin/guile" +guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm" + if echo foo | guix archive --authorize then false; else true; fi -- cgit v1.2.3 From 4736d06f78e09883bdd24186c396cdd4e6a74a6f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Dec 2019 23:07:03 +0100 Subject: challenge: Report the best narinfo URI. * guix/scripts/substitute.scm (select-uri): Rename to... (narinfo-best-uri): ... this, and make public. Update callers. * guix/scripts/challenge.scm (summarize-report): Use 'narinfo-best-uri' instead of (first (narinfo-uris ...)). --- guix/scripts/challenge.scm | 2 +- guix/scripts/substitute.scm | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 17e87f0291..aabb2ee549 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -192,7 +192,7 @@ inconclusive reports." (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)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b6034a75d2..4802fbd1fe 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 @@ -913,7 +914,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 +968,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 +1009,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)) -- cgit v1.2.3 From 1d9a4456a83a197a47bf2bdebc6b60ae78e00cfc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Dec 2019 00:20:54 +0100 Subject: serialization: Remove unused procedure. * guix/serialization.scm (write-contents): Remove. --- guix/serialization.scm | 18 ------------------ 1 file changed, 18 deletions(-) (limited to 'guix') diff --git a/guix/serialization.scm b/guix/serialization.scm index cf263d321e..f793feb53d 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -199,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) -- cgit v1.2.3 From 22f06a212879369bd1d7f3aa5b19f8f89a8c6693 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Dec 2019 00:40:41 +0100 Subject: progress: Add 'progress-report-port'. * guix/scripts/substitute.scm (progress-report-port): Move to... * guix/progress.scm (progress-report-port): ... here. New procedure. --- guix/progress.scm | 31 +++++++++++++++++++++++++++++++ guix/scripts/substitute.scm | 29 ----------------------------- 2 files changed, 31 insertions(+), 29 deletions(-) (limited to 'guix') 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 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 object." + (match 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/scripts/substitute.scm b/guix/scripts/substitute.scm index 4802fbd1fe..7eca2c6874 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -823,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 object." - (match 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." -- cgit v1.2.3 From 5208db3a526e3fcdb8473d9bab8afe498c5f3f76 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 7 Dec 2019 15:10:39 +0100 Subject: challenge: Add "--diff". * guix/scripts/challenge.scm (dump-port*): New variable. (archive-contents, store-item-contents, narinfo-contents) (differing-files, report-differing-files): New procedures. (summarize-report): Add #:report-differences and call it. (show-help, %options): Add "--diff". (%default-options): Add 'difference-report' key. (report-differing-files): Parameterize CURRENT-TERMINAL-COLUMNS and pass #:report-differences to 'summarize-report'. * guix/tests/http.scm (%local-url): Add optional argument. (call-with-http-server): Fix docstring typo. * tests/challenge.scm (query-path-size, make-narinfo): New procedures. ("differing-files"): New test. * doc/guix.texi (Invoking guix challenge): Document "--diff". --- doc/guix.texi | 24 +++++++ guix/scripts/challenge.scm | 156 +++++++++++++++++++++++++++++++++++++++++++-- guix/tests/http.scm | 6 +- tests/challenge.scm | 67 ++++++++++++++++++- 4 files changed, 242 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index cb51878004..80d67a44fa 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10321,14 +10321,23 @@ updating list of substitutes from 'https://guix.example.org'... 100.0% local hash: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-openssl-1.0.2d: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q https://guix.example.org/nar/@dots{}-openssl-1.0.2d: 1zy4fmaaqcnjrzzajkdn3f5gmjk754b43qkq47llbyak9z0qjyim + differing files: + /lib/libcrypto.so.1.1 + /lib/libssl.so.1.1 + /gnu/store/@dots{}-git-2.5.0 contents differ: local hash: 00p3bmryhjxrhpn2gxs2fy0a15lnip05l97205pgbk5ra395hyha https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0: 069nb85bv4d4a6slrwjdy8v1cn4cwspm3kdbmyb81d6zckj3nq9f https://guix.example.org/nar/@dots{}-git-2.5.0: 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73 + differing file: + /libexec/git-core/git-fsck + /gnu/store/@dots{}-pius-2.1.1 contents differ: local hash: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-pius-2.1.1: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax https://guix.example.org/nar/@dots{}-pius-2.1.1: 1cy25x1a4fzq5rk0pmvc8xhwyffnqz95h2bpvqsz2mpvlbccy0gs + differing file: + /share/man/man1/pius.1.gz @dots{} @@ -10414,6 +10423,21 @@ The one option that matters is: Consider @var{urls} the whitespace-separated list of substitute source URLs to compare to. +@item --diff=@var{mode} +Upon mismatches, show differences according to @var{mode}, one of: + +@table @asis +@item @code{simple} (the default) +Show the list of files that differ. + +@item @code{none} +Do not show further details about the differences. +@end table + +Thus, unless @code{--diff=none} is passed, @command{guix challenge} +downloads the store items from the given substitute servers so that it +can compare them. + @item --verbose @itemx -v Show details about matches (identical contents) in addition to diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index aabb2ee549..277eec9a5d 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,8 @@ comparison-report-mismatch? comparison-report-inconclusive? + differing-files + guix-challenge)) ;;; Commentary: @@ -179,13 +187,128 @@ 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 (narinfo-contents narinfo) + "Fetch the nar described by NARINFO and return a list representing the file +it contains." + (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) + archive-contents)) + + (close-port port) + (erase-current-line (current-output-port)) + result)) + +(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* (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 -object. When VERBOSE?, display matches in addition to mismatches and -inconclusive reports." + "Write to the current error port a summary of COMPARISON-REPORT, a + 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)) @@ -200,7 +323,8 @@ inconclusive reports." (match 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)) (($ item 'inconclusive #f narinfos) (warning (G_ "could not challenge '~a': no local build~%") item)) (($ item 'inconclusive locals ()) @@ -237,6 +361,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 +380,18 @@ 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) + (_ (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 +407,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 +425,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 +446,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/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/tests/challenge.scm b/tests/challenge.scm index c962800f3f..a2782abcbd 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès +;;; Copyright © 2015, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,22 +18,32 @@ (define-module (test-challenge) #:use-module (guix tests) + #:use-module (guix tests http) #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) + #:use-module (guix serialization) + #:use-module (guix packages) #:use-module (guix gexp) + #:use-module (guix base32) #:use-module (guix scripts challenge) #:use-module (guix scripts substitute) + #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) #:use-module (ice-9 match)) (define query-path-hash* (store-lift query-path-hash)) +(define (query-path-size item) + (mlet %store-monad ((info (query-path-info* item))) + (return (path-info-nar-size info)))) + (define* (call-with-derivation-narinfo* drv thunk hash) (lambda (store) (with-derivation-narinfo drv (sha256 => hash) @@ -138,7 +148,62 @@ (bytevector=? (narinfo-hash->sha256 (narinfo-hash narinfo)) hash)))))))))))) +(define (make-narinfo item size hash) + (format #f "StorePath: ~a +Compression: none +URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo +NarSize: ~d +NarHash: sha256:~a +References: ~%" item size (bytevector->nix-base32-string hash))) +(test-assertm "differing-files" + ;; Pretend we have two different results for the same store item, ITEM, + ;; with "/bin/guile" differing between the two nars, and make sure + ;; 'differing-files' returns it. + (mlet* %store-monad + ((drv1 (package->derivation %bootstrap-guile)) + (drv2 (gexp->derivation + "broken-guile" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (copy-recursively #$drv1 #$output) + (chmod (string-append #$output "/bin/guile") + #o755) + (call-with-output-file (string-append + #$output + "/bin/guile") + (lambda (port) + (display "corrupt!" port))))))) + (out1 -> (derivation->output-path drv1)) + (out2 -> (derivation->output-path drv2)) + (item -> (string-append (%store-prefix) "/" + (make-string 32 #\a) "-foo"))) + (mbegin %store-monad + (built-derivations (list drv1 drv2)) + (mlet* %store-monad ((size1 (query-path-size out1)) + (size2 (query-path-size out2)) + (hash1 (query-path-hash* out1)) + (hash2 (query-path-hash* out2)) + (nar1 -> (call-with-bytevector-output-port + (lambda (port) + (write-file out1 port)))) + (nar2 -> (call-with-bytevector-output-port + (lambda (port) + (write-file out2 port))))) + (parameterize ((%http-server-port 9000)) + (with-http-server `((200 ,(make-narinfo item size1 hash1)) + (200 ,nar1)) + (parameterize ((%http-server-port 9001)) + (with-http-server `((200 ,(make-narinfo item size2 hash2)) + (200 ,nar2)) + (mlet* %store-monad ((urls -> (list (%local-url 9000) + (%local-url 9001))) + (reports (compare-contents (list item) + urls))) + (pk 'report reports) + (return (equal? (differing-files (car reports)) + '("/bin/guile")))))))))))) (test-end) -- cgit v1.2.3 From 828a39da68a9169ef1d9f9ff02a1c66b1bcbe884 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 7 Dec 2019 17:37:08 +0100 Subject: challenge: Support "--diff=diffoscope". * guix/scripts/challenge.scm (call-with-nar): New procedure. (narinfo-contents): Express in terms of 'call-with-nar'. (call-with-mismatches, report-differing-files/external): New procedures. (%diffoscope-command): New variable. (%options): Support "diffoscope" and a string starting with "/". * tests/challenge.scm (call-mismatch-test): New procedure. ("differing-files"): Rewrite in terms of 'call-mismatch-test'. ("call-with-mismatches"): New test. * doc/guix.texi (Invoking guix challenge): Document it. --- doc/guix.texi | 24 ++++++++++++++-- guix/scripts/challenge.scm | 70 +++++++++++++++++++++++++++++++++++++++++++--- tests/challenge.scm | 51 +++++++++++++++++++++++++-------- 3 files changed, 128 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 80d67a44fa..a5cff4cab2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10366,8 +10366,20 @@ results, the inclusion of random numbers, and directory listings sorted by inode number. See @uref{https://reproducible-builds.org/docs/}, for more information. -To find out what is wrong with this Git binary, we can do something along -these lines (@pxref{Invoking guix archive}): +To find out what is wrong with this Git binary, the easiest approach is +to run: + +@example +guix challenge git \ + --diff=diffoscope \ + --substitute-urls="https://@value{SUBSTITUTE-SERVER} https://guix.example.org" +@end example + +This automatically invokes @command{diffoscope}, which displays detailed +information about files that differ. + +Alternately, we can do something along these lines (@pxref{Invoking guix +archive}): @example $ wget -q -O - https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0 \ @@ -10430,6 +10442,14 @@ Upon mismatches, show differences according to @var{mode}, one of: @item @code{simple} (the default) Show the list of files that differ. +@item @code{diffoscope} +@itemx @var{command} +Invoke @uref{https://diffoscope.org/, Diffoscope}, passing it +two directories whose contents do not match. + +When @var{command} is an absolute file name, run @var{command} instead +of Diffoscope. + @item @code{none} Do not show further details about the differences. @end table diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 277eec9a5d..51e8d3e4e3 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -56,6 +56,7 @@ comparison-report-inconclusive? differing-files + call-with-mismatches guix-challenge)) @@ -248,9 +249,9 @@ taken since we do not import the archives." item lstat)) -(define (narinfo-contents narinfo) - "Fetch the nar described by NARINFO and return a list representing the file -it contains." +(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) @@ -262,12 +263,17 @@ it contains." (define result (call-with-decompressed-port (string->symbol compression) (progress-report-port reporter port) - archive-contents)) + 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." @@ -300,6 +306,58 @@ specified in COMPARISON-REPORT." (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 (string=? (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)) @@ -386,6 +444,10 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (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 diff --git a/tests/challenge.scm b/tests/challenge.scm index a2782abcbd..bb5633a3eb 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -29,6 +29,7 @@ #:use-module (guix base32) #:use-module (guix scripts challenge) #:use-module (guix scripts substitute) + #:use-module ((guix build utils) #:select (find-files)) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -156,10 +157,12 @@ NarSize: ~d NarHash: sha256:~a References: ~%" item size (bytevector->nix-base32-string hash))) -(test-assertm "differing-files" - ;; Pretend we have two different results for the same store item, ITEM, - ;; with "/bin/guile" differing between the two nars, and make sure - ;; 'differing-files' returns it. +(define (call-mismatch-test proc) + "Pass PROC a for a mismatch and return its return +value." + + ;; Pretend we have two different results for the same store item, ITEM, with + ;; "/bin/guile" differing between the two nars. (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile)) (drv2 (gexp->derivation @@ -178,7 +181,10 @@ References: ~%" item size (bytevector->nix-base32-string hash))) (out1 -> (derivation->output-path drv1)) (out2 -> (derivation->output-path drv2)) (item -> (string-append (%store-prefix) "/" - (make-string 32 #\a) "-foo"))) + (bytevector->nix-base32-string + (random-bytevector 32)) + "-foo" + (number->string (current-time) 16)))) (mbegin %store-monad (built-derivations (list drv1 drv2)) (mlet* %store-monad ((size1 (query-path-size out1)) @@ -186,11 +192,11 @@ References: ~%" item size (bytevector->nix-base32-string hash))) (hash1 (query-path-hash* out1)) (hash2 (query-path-hash* out2)) (nar1 -> (call-with-bytevector-output-port - (lambda (port) - (write-file out1 port)))) + (lambda (port) + (write-file out1 port)))) (nar2 -> (call-with-bytevector-output-port - (lambda (port) - (write-file out2 port))))) + (lambda (port) + (write-file out2 port))))) (parameterize ((%http-server-port 9000)) (with-http-server `((200 ,(make-narinfo item size1 hash1)) (200 ,nar1)) @@ -202,8 +208,31 @@ References: ~%" item size (bytevector->nix-base32-string hash))) (reports (compare-contents (list item) urls))) (pk 'report reports) - (return (equal? (differing-files (car reports)) - '("/bin/guile")))))))))))) + (return (proc (car reports)))))))))))) + +(test-assertm "differing-files" + (call-mismatch-test + (lambda (report) + (equal? (differing-files report) '("/bin/guile"))))) + +(test-assertm "call-with-mismatches" + (call-mismatch-test + (lambda (report) + (call-with-mismatches + report + (lambda (directory1 directory2) + (let* ((files1 (find-files directory1)) + (files2 (find-files directory2)) + (files (map (cute string-drop <> (string-length directory1)) + files1))) + (and (equal? files + (map (cute string-drop <> (string-length directory2)) + files2)) + (equal? (remove (lambda (file) + (file=? (string-append directory1 "/" file) + (string-append directory2 "/" file))) + files) + '("/bin/guile"))))))))) (test-end) -- cgit v1.2.3 From e34e02707d6bd38c79ce7bec776fcdc528548a0d Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 13 Dec 2019 10:33:42 +0900 Subject: emacs-build-system: Ensure the core libraries appear last in the load path. Fixes bug #38568 (see: https://bugs.gnu.org/38568). * guix/build/emacs-build-system.scm (add-source-to-load-path): Ensure the core libraries appear last in the load path. Reported-by: Jelle Licht --- guix/build/emacs-build-system.scm | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'guix') 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))) -- cgit v1.2.3 From 6212146f887327b0ef017702982194f2d8180178 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Dec 2019 22:18:37 +0100 Subject: import: utils: Update docstring of 'recursive-import'. This is a followup to 70a8e13277d4a44b89dd9ee2290b98105f0235f1. * guix/import/utils.scm (recursive-import): Update docstring. --- guix/import/utils.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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 -- cgit v1.2.3 From e31ec53ed808ad7c949ec23521c87ed29b74c5e0 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 14 Dec 2019 13:34:53 +0100 Subject: import: cran: Recognize LGPL 2.1+. * guix/import/cran.scm (string->license): Add case for lgpl2.1+. --- guix/import/cran.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index d9018cc7da..0aee0c7cd7 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) -- cgit v1.2.3 From 428561aa63e7ddcafdd80a50e2b147fc97f77662 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Dec 2019 14:59:32 +0100 Subject: challenge: Fix type mismatch when comparing to a local hash. * guix/scripts/challenge.scm (call-with-mismatches)[narinfo1]: When LOCAL-HASH is true, call 'narinfo-hash->sha256' and use 'bytevector=?' instead of 'string=?'. --- guix/scripts/challenge.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 51e8d3e4e3..ebeebd5cbe 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -321,8 +321,9 @@ specified in COMPARISON-REPORT." (define narinfo1 (if local-hash (find (lambda (narinfo) - (not (string=? (narinfo-hash narinfo) - local-hash))) + (not (bytevector=? (narinfo-hash->sha256 + (narinfo-hash narinfo)) + local-hash))) narinfos) (first (comparison-report-narinfos comparison-report)))) -- cgit v1.2.3 From 5f9cd63eb0d803966ce645c9d1db3438370e5505 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Dec 2019 00:11:30 +0100 Subject: base64: Do not use (rnrs). * guix/base64.scm: Remove #:use-module clauses for (rnrs) and (srfi srfi-13). Add other #:use-module clauses. (fxbit-field): Define as an alias for 'bit-field. (fx=?, fx+, mod): New aliases. (assert): New macro. --- guix/base64.scm | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'guix') 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+/") -- cgit v1.2.3 From f431d5e299b9e00c22b02e9d5464e6d4196561ba Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 14 Dec 2019 15:54:50 +0100 Subject: guix: Upgrade to Bioconductor 3.10. * guix/build-system/r.scm (bioconductor-uri): Switch to version 3.10. * guix/import/cran.scm (%bioconductor-version): Same. --- guix/build-system/r.scm | 2 +- guix/import/cran.scm | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') 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/import/cran.scm b/guix/import/cran.scm index 0aee0c7cd7..f3f1747e43 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -133,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/" -- cgit v1.2.3 From 356a79becc4061d158c68718ad169abac1ab672f Mon Sep 17 00:00:00 2001 From: Björn Höfling Date: Sun, 15 Dec 2019 22:00:56 +0100 Subject: swh: Fix API call for getting origin. When using the archival linter, git origins already in the archive where not recognized due to an API change and where repeatedly asked for archival. This is fixed here. * guix/swh.scm (lookup-origin): Fix API URI for getting origin. (): Fix comment with API URI example. --- guix/swh.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 7acad05928..372e4c84d1 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))))) -;; +;; (define-json-mapping 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) -- cgit v1.2.3 From ab7010af1f1077c056529769a53a380147c3933f Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sun, 15 Dec 2019 21:27:31 +0100 Subject: gexp: Allow character literals in GEXP->SEXP. Fixes . * tests/gexp.scm ("lower-gexp, character literal"): New test. * guix/gexp.scm (gexp->sexp)[self-quoting?]: Add CHAR? to the tested types. * guix/repl.scm (self-quoting?): Likewise. * gnu/tests.scm (marionette-shepherd-service)[self-quoting?]: Likewise. --- gnu/tests.scm | 2 +- guix/gexp.scm | 2 +- guix/repl.scm | 2 +- tests/gexp.scm | 6 ++++++ 4 files changed, 9 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/gnu/tests.scm b/gnu/tests.scm index 27cb39c2b9..cc72e56858 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -98,7 +98,7 @@ (or (pred x) (one-of rest ...)))))) (one-of symbol? string? keyword? pair? null? array? - number? boolean?))) + number? boolean? char?))) (match (primitive-fork) (0 diff --git a/guix/gexp.scm b/guix/gexp.scm index a96592ac76..411f0844ff 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1028,7 +1028,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/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/tests/gexp.scm b/tests/gexp.scm index 84c16422c2..8b1596f66d 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -886,6 +886,12 @@ (run-with-store %store (lower-gexp #~(foo #$+))))) +(test-equal "lower-gexp, character literal" + '(#\+) + (lowered-gexp-sexp + (run-with-store %store + (lower-gexp #~(#\+))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) -- cgit v1.2.3 From 6afea7489b76c8db58d4f389fdbedc7c2b8992bd Mon Sep 17 00:00:00 2001 From: Björn Höfling Date: Wed, 18 Dec 2019 22:31:05 +0100 Subject: guix: swh: Fix example URI in comment for . This is a one-character follow-up to 356a79becc4061d158c68718ad169abac1ab672f Reported by Jonathan Brielmaier . * guix/swh.scm(): Remove a slash from example URI witin a comment. --- guix/swh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 372e4c84d1..70eeef5c6b 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))))) -;; +;; (define-json-mapping make-origin origin? json->origin (id origin-id) -- cgit v1.2.3 From 9cfa322579e1be0adf0e2e1c489d336a4e5eedf7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Dec 2019 17:19:00 +0100 Subject: gnupg: 'gnupg-status-good-signature?' no longer returns a key ID. Returning a key ID was inconsequential because the only user of 'gnupg-status-good-signature?', (guix upstream) (via 'gnupg-verify*'), would not check the return value as long as it's true. * guix/gnupg.scm (gnupg-status-good-signature?): Return a fingerprint/user pair instead of key-id/user. (gnupg-verify*): Mention it in docstring. --- guix/gnupg.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/gnupg.scm b/guix/gnupg.scm index 40feb44561..bf01c7fe0b 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 +;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -142,13 +142,15 @@ 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 @@ -178,7 +180,8 @@ missing key." "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)." +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))) -- cgit v1.2.3 From 217b4a1587e8b9af6526915a10e648f58234ebf0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Dec 2019 17:37:02 +0100 Subject: gnupg: 'gnupg-status-missing-key?' returns a fingerprint when possible. Until then, 'gnupg-status-missing-key?' would return a key id. Its user, 'gnupg-verify*', would then fetch a key with that ID from key servers, thus possibly the wrong key (due to key ID collisions). If it did fetch the wrong key, the effect would be a signature verification failure down the path--e.g., in "guix refresh -u". * guix/gnupg.scm (gnupg-verify)[maybe-fingerprint]: New procedure. [status-line->sexp](errsig-rx): Add parenthetical expression at the end. Fetch it and add it to the 'signature-error' sexp. (gnupg-status-missing-key?): Match the whole 'signature-error' sexp and return preferably the fingerprint rather than KEY-ID. (gnupg-receive-keys): Rename 'key-id' parameter to 'fingerprint/key-id'. --- guix/gnupg.scm | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/gnupg.scm b/guix/gnupg.scm index bf01c7fe0b..5b11aa93fa 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -65,6 +65,11 @@ KEYRING as assumed to be \"trusted\", whether or not they expired or were revoked. Return a status s-exp if GnuPG failed." + (define (maybe-fingerprint str) + (match (string-trim-both str) + ((or "-" "") #f) + (fpr fpr))) + (define (status-line->sexp line) ;; See file `doc/DETAILS' in GnuPG. (define sigid-rx @@ -78,8 +83,10 @@ revoked. Return a status s-exp if GnuPG failed." (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:]]+)")) + "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)")) (cond ((regexp-exec sigid-rx line) => @@ -108,7 +115,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 +127,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)))) @@ -153,16 +162,16 @@ a fingerprint/user pair; return #f otherwise." #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))) (unless (file-exists? keyring) (mkdir-p (dirname keyring)) @@ -170,7 +179,7 @@ missing key." (system* (%gpg-command) "--keyserver" server "--no-default-keyring" "--keyring" keyring - "--recv-keys" key-id)) + "--recv-keys" fingerprint/key-id)) (define* (gnupg-verify* sig file #:key -- cgit v1.2.3 From 09f9167cd4656ba05989390a4e8e3e23d5f5b9b7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 18 Dec 2019 16:32:52 -0500 Subject: download: Remove ramses.wh2.tu-dresden.de kernel mirror. * guix/download.scm (%mirrors): Remove ramses.wh2.tu-dresden.de, which seems to no longer work. --- guix/download.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') 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/" -- cgit v1.2.3 From 003fcf23d9bd2f8014f5b4fe931b994bba5b8b28 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 19 Dec 2019 10:35:00 +0200 Subject: guix: Fix %hurd-systems list. * guix/packages.scm (%hurd-systems): Replace i585-gnu with i586-gnu. --- guix/packages.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') 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 ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2016 Alex Kost -;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2017, 2019 Efraim Flashner ;;; Copyright © 2019 Marius Bakke ;;; ;;; 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. -- cgit v1.2.3 From d8169d05bb9e7d70597a646c95ee4001809070ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Dec 2019 22:16:50 +0100 Subject: gnupg: Compile regexps only once. This halves the run time on a large number of subsequent 'gnupg-verify' calls. * guix/gnupg.scm (sigid-rx, goodsig-rx, validsig-rx, expkeysig-rx) (errsig-rx): New variables, lifted from... (gnupg-verify)[status-line->sexp]: ... here. --- guix/gnupg.scm | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/gnupg.scm b/guix/gnupg.scm index 5b11aa93fa..35ab779e9c 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -59,6 +59,25 @@ ;; 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 @@ -71,23 +90,6 @@ revoked. Return a status s-exp if GnuPG failed." (fpr fpr))) (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 - ;; 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:]]+)(.*)")) - (cond ((regexp-exec sigid-rx line) => (lambda (match) -- cgit v1.2.3 From f94f9d67e65975724ee5b5cbc936c0895a258685 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Dec 2019 21:49:43 +0100 Subject: gnupg: 'gnupg-verify*' returns a status symbol. This allows callers to distinguish between signature verification failure and missing key. * guix/gnupg.scm (gnupg-receive-keys): Return true on success. (gnupg-verify*): Check return value of 'gnupg-receive-keys'. Return two values, the first one being a symbol. * guix/upstream.scm (download-tarball): Get the two return values of 'gnupg-verify*', and match on the first one. * gnu/packages/bash.scm (download-patches): Check the first return value of 'gnupg-verify*'. --- gnu/packages/bash.scm | 4 +-- guix/gnupg.scm | 78 ++++++++++++++++++++++++++++++--------------------- guix/upstream.scm | 24 +++++++++------- 3 files changed, 62 insertions(+), 44 deletions(-) (limited to 'guix') diff --git a/gnu/packages/bash.scm b/gnu/packages/bash.scm index bb2397fafa..3af13a612a 100644 --- a/gnu/packages/bash.scm +++ b/gnu/packages/bash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; Copyright © 2014, 2015, 2018 Mark H Weaver ;;; Copyright © 2015, 2017 Leo Famulari ;;; Copyright © 2016, 2017, 2018, 2019 Efraim Flashner @@ -80,7 +80,7 @@ number/base32-hash tuples, directly usable in the 'patch-series' form." (sig (download-to-store store (string-append (patch-url number) ".sig")))) - (unless (gnupg-verify* sig patch) + (unless (eq? 'valid-signature (gnupg-verify* sig patch)) (error "failed to verify signature" patch)) (list number diff --git a/guix/gnupg.scm b/guix/gnupg.scm index 35ab779e9c..bf0283f8fe 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -175,13 +175,15 @@ missing key or its key id if the fingerprint is unavailable." (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" fingerprint/key-id)) + (zero? (system* (%gpg-command) "--keyserver" server + "--no-default-keyring" "--keyring" keyring + "--recv-keys" fingerprint/key-id))) (define* (gnupg-verify* sig file #:key @@ -189,36 +191,48 @@ missing key or its key id if the fingerprint is unavailable." (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 a fingerprint/user name pair on success -and #f otherwise." +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/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 -- cgit v1.2.3 From 89bbcc80d7a6867515ba1057c98accf41cbb9077 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Dec 2019 16:27:31 +0100 Subject: guix system: Honor the build options in 'delete-generations'. Until now, 'guix system delete-generations' would ignore OPTS; for example, it would not enable #:print-extended-build-trace? & co., leading to suboptimal output. * guix/scripts/system.scm (process-command)[with-store*]: New macro. Use it for 'delete-generations', 'switch-generation', and 'roll-back'. --- guix/scripts/system.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'guix') 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 -- cgit v1.2.3 From 7e0539649cb96150b09614335c7f26a521c7bb35 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 14 Dec 2019 17:52:53 +0100 Subject: gexp: Add system and target support to gexp->file. * guix/gexp.scm (gexp->file): Add system and target arguments and pass them to gexp->derivation and load-path-expression calls, (scheme-file-compiler): adapt accordingly to pass system and target arguments. --- guix/gexp.scm | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 411f0844ff..12331052a6 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; Copyright © 2018 Jan Nieuwenhuizen +;;; Copyright © 2019 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -456,7 +457,10 @@ This is the declarative counterpart of 'gexp->file'." ;; Compile FILE by returning a derivation that builds the file. (match file (($ name gexp splice?) - (gexp->file name gexp #:splice? splice?)))) + (gexp->file name gexp + #:splice? splice? + #:system system + #:target target)))) ;; Appending SUFFIX to BASE's output file name. (define-record-type @@ -1603,7 +1607,9 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH." (define* (gexp->file name exp #:key (set-load-path? #t) (module-path %load-path) - (splice? #f)) + (splice? #f) + (system (%current-system)) + target) "Return a derivation that builds a file NAME containing EXP. When SPLICE? is true, EXP is considered to be a list of expressions that will be spliced in the resulting file. @@ -1626,10 +1632,14 @@ Lookup EXP's modules in MODULE-PATH." exp (gexp ((ungexp exp))))))))) #:local-build? #t - #:substitutable? #f) + #:substitutable? #f + #:system system + #:target target) (mlet %store-monad ((set-load-path (load-path-expression modules module-path - #:extensions extensions))) + #:extensions extensions + #:system system + #:target target))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1642,7 +1652,9 @@ Lookup EXP's modules in MODULE-PATH." (gexp ((ungexp exp))))))))) #:module-path module-path #:local-build? #t - #:substitutable? #f)))) + #:substitutable? #f + #:system system + #:target target)))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing -- cgit v1.2.3 From fce8ec9e1514a25f3698553449635a2fe5d80811 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 22 Dec 2019 20:31:40 +0100 Subject: build-system: qt: Actually use qt-build-system, not cmake-build-system. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit When the qt-build-system was created, based on the cmake-build-system, some references to cmake have been missed to be changed. * guix/build-system/qt.scm (qt-build, qt-cross-build)[modules]: Use qt-build-system, not cmake-build-system. [builder]: Call qt-build, not cmake-build. Coauthored-by: Ludovic Courtès --- guix/build-system/qt.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index b776845377..67fdfa1230 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -126,14 +126,14 @@ (qt-wrap-excluded-outputs ''()) (system (%current-system)) (imported-modules %qt-build-system-modules) - (modules '((guix build cmake-build-system) + (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") + (qt-build #:source ,(match (assoc-ref inputs "source") (((? derivation? source)) (derivation->output-path source)) ((source) @@ -208,7 +208,7 @@ provides a 'CMakeLists.txt' file as its build system." (system (%current-system)) (build (nix-system->gnu-triplet system)) (imported-modules %qt-build-system-modules) - (modules '((guix build cmake-build-system) + (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 @@ -237,7 +237,7 @@ build system." `(,name . ,path))) target-drvs)) - (cmake-build #:source ,(match (assoc-ref native-drvs "source") + (qt-build #:source ,(match (assoc-ref native-drvs "source") (((? derivation? source)) (derivation->output-path source)) ((source) -- cgit v1.2.3 From c19260ea00dae351352364705ab6d2680f815847 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Mon, 23 Dec 2019 15:48:21 +0100 Subject: build-system: qt: Adjust indentation. * guix/build-system/qt.scm (qt-build, qt-cross-build): Adjust indentation. --- guix/build-system/qt.scm | 210 +++++++++++++++++++++++------------------------ 1 file changed, 105 insertions(+), 105 deletions(-) (limited to 'guix') diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index 67fdfa1230..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 qt-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) (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))) + (((? 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 qt-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." @@ -238,37 +238,37 @@ build system." target-drvs)) (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)))) + (((? 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 -- cgit v1.2.3 From e507d30c482cf018b44e70931a6153e5d3ea93f1 Mon Sep 17 00:00:00 2001 From: Björn Höfling Date: Thu, 26 Dec 2019 00:19:39 +0100 Subject: guix: swh: Fix again example URI in comment for . This is a follow up to 6afea7489b76c8db58d4f389fdbedc7c2b8992bd * guix/swh.scm(): Write 'https' instead of 'ttps' for the URL. --- guix/swh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 70eeef5c6b..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))))) -;; +;; (define-json-mapping make-origin origin? json->origin (id origin-id) -- cgit v1.2.3 From 87a028100c665814c3b5d622701abc6d77144faf Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 26 Dec 2019 10:02:56 +0200 Subject: build-system: linux-module: Add substitutable keyword. * guix/build-system/linux-module.scm (linux-module-build) Add substitutable keyword. --- guix/build-system/linux-module.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') 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 -- cgit v1.2.3 From 3c45b53ec9025f4b95ec003ff99caa3e6fe506ab Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 26 Dec 2019 12:29:44 +0100 Subject: gnu: Remove squashfs-tools-next. * gnu/packages/compression.scm (squashfs-tools-next): Remove variable. * guix/scripts/pack.scm (squashfs-image, guix-pack): Use squashfs-tools. * tests/pack.scm: Use squashfs-tools. --- gnu/packages/compression.scm | 17 ----------------- guix/scripts/pack.scm | 4 ++-- tests/pack.scm | 4 ++-- 3 files changed, 4 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm index 02e4e324b9..cf23e88547 100644 --- a/gnu/packages/compression.scm +++ b/gnu/packages/compression.scm @@ -819,23 +819,6 @@ systems where low overhead is needed. This package allows you to create and extract such file systems.") (license license:gpl2+))) -;; We need this for building squashfs images with symlinks. -(define-public squashfs-tools-next - (let ((commit "fb33dfc32b131a1162dcf0e35bd88254ae10e265") - (revision "1")) - (package (inherit squashfs-tools) - (name "squashfs-tools-next") - (version (string-append "4.3-" revision (string-take commit 7))) - (source (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/plougher/squashfs-tools.git") - (commit commit))) - (file-name (git-file-name name version)) - (sha256 - (base32 - "1x2skf8hxzfch978nzx5mh46d4hhi6gl22270hiarjszsjk3bnsx"))))))) - (define-public pigz (package (name "pigz") diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index bbacc93bc0..9676d28565 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. @@ -1045,7 +1045,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/tests/pack.scm b/tests/pack.scm index 71ff5aec18..0c1406e687 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -28,7 +28,7 @@ #:use-module (guix tests) #:use-module (guix gexp) #:use-module (gnu packages bootstrap) - #:use-module ((gnu packages compression) #:select (squashfs-tools-next)) + #:use-module ((gnu packages compression) #:select (squashfs-tools)) #:use-module (srfi srfi-64)) (define %store @@ -199,7 +199,7 @@ (string-append "." #$profile "/bin")) (setenv "PATH" - (string-append #$squashfs-tools-next "/bin")) + (string-append #$squashfs-tools "/bin")) (invoke "unsquashfs" #$image) (with-directory-excursion "squashfs-root" (when (and (file-exists? (string-append bin -- cgit v1.2.3 From 621fb83a1fde948b3b7eea37bdc378cbf1b3d11e Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Thu, 19 Dec 2019 00:32:11 +0100 Subject: download: Enable TLS 1.3. This reverts commit e4ee84202633636b4c8cef4a332f0c74912a3b23. * guix/build/download.scm (tls-wrap): Dot not disable TLS 1.3. --- guix/build/download.scm | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) (limited to 'guix') 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 . (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 . ;; Explicitly disable SSLv3, which is insecure: ;; . - ;; - ;; FIXME: Since we currently fail to handle TLS 1.3 (with GnuTLS 3.6.5), - ;; remove it; see . - (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) -- cgit v1.2.3 From 785af04a7574867dc940c791daa938a2432d0450 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Dec 2019 13:15:00 +0100 Subject: git: 'commit-difference' takes a list of excluded commits. * guix/git.scm (commit-closure): Add 'visited' optional parameter. (commit-difference): Add 'excluded' optional parameter; pass second argument to 'commit-closure'. * tests/git.scm ("commit-difference, excluded commits"): New test. --- guix/git.scm | 14 ++++++++------ tests/git.scm | 26 ++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 6 deletions(-) (limited to 'guix') 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/tests/git.scm b/tests/git.scm index 8ba10ece51..052f8a79c4 100644 --- a/tests/git.scm +++ b/tests/git.scm @@ -96,4 +96,30 @@ (lset= eq? (commit-difference master4 master2) (list master4 merge master3 devel1 devel2))))))) +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, excluded commits" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (add "d.txt" "D") + (commit "fourth commit") + (add "e.txt" "E") + (commit "fifth commit")) + (with-repository directory repository + (let ((commit1 (find-commit repository "first")) + (commit2 (find-commit repository "second")) + (commit3 (find-commit repository "third")) + (commit4 (find-commit repository "fourth")) + (commit5 (find-commit repository "fifth"))) + (and (lset= eq? (commit-difference commit4 commit1 (list commit2)) + (list commit3 commit4)) + (lset= eq? (commit-difference commit4 commit1 (list commit3)) + (list commit4)) + (lset= eq? (commit-difference commit4 commit1 (list commit5)) + (list commit2 commit3 commit4))))))) + (test-end "git") -- cgit v1.2.3 From 9ce3f7f6dc49aef3153a8d58c96528808e82fb3f Mon Sep 17 00:00:00 2001 From: Leo Prikler Date: Sun, 15 Dec 2019 00:45:08 +0100 Subject: guix: emacs-utils: Add emacs-batch-disable-compilation. * guix/build/emacs-utils.scm (emacs-batch-disable-compilation): New procedure. Signed-off-by: Brett Gilio --- guix/build/emacs-utils.scm | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'guix') 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 ;;; Copyright © 2014 Alex Kost ;;; Copyright © 2018 Maxim Cournoyer +;;; Copyright © 2019 Leo Prikler ;;; ;;; 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")) -- cgit v1.2.3 From 8a705ae4c6107f43c7fbcfad913dd2675f94086a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2019 16:19:56 +0100 Subject: profiles: Add 'map-manifest-entries'. * guix/scripts/pack.scm (map-manifest-entries): Move to... * guix/profiles.scm (map-manifest-entries): ... here. --- guix/profiles.scm | 6 ++++++ guix/scripts/pack.scm | 5 ----- 2 files changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 616605151e..5b3b5bd5fe 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -93,6 +93,7 @@ manifest-pattern-output concatenate-manifests + map-manifest-entries manifest-remove manifest-add manifest-lookup @@ -520,6 +521,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/scripts/pack.scm b/guix/scripts/pack.scm index 9676d28565..536cc1726c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -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. -- cgit v1.2.3 From c48e522fdbb7c749bbf6147e44c067bf1f916fdd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2019 16:22:35 +0100 Subject: guix package: Save provenance information when using '--manifest'. Fixes . Reported by zimoun . * guix/describe.scm (manifest-entry-with-provenance): New procedure. * guix/scripts/package.scm (process-actions): Use it when FILES is non-empty. --- guix/describe.scm | 18 +++++++++++++++++- guix/scripts/package.scm | 7 +++++-- 2 files changed, 22 insertions(+), 3 deletions(-) (limited to 'guix') 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/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)) -- cgit v1.2.3 From 975183a1c428198fe639fa37552ae069692b1f15 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2019 16:51:15 +0100 Subject: pack: Save provenance information when using '--manifest'. * guix/scripts/pack.scm (guix-pack)[manifest-from-args]: Remove 'provenance', and add 'with-provenance' procedure. Wrap 'cond' form in 'with-provenance'. --- guix/scripts/pack.scm | 54 ++++++++++++++++++++++++--------------------------- 1 file changed, 25 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 536cc1726c..b84e37cbf2 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -974,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 -- cgit v1.2.3 From 7a241c63503c81a0f9ed284c7cc66da058aa00cf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2019 17:35:56 +0100 Subject: inferior: Add 'inferior-package-provenance'. * guix/inferior.scm (inferior-package-provenance): New procedure. --- guix/inferior.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'guix') 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 -- cgit v1.2.3 From e51de34309be7ba8105be66d45d7da4a64883b08 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 24 Dec 2019 15:04:57 +0100 Subject: profiles: Fix profile-derivation cross-compilation. * guix/store.scm (current-target-system): New exported monadic procedure. * guix/profiles.scm (profile-derivation): Set target at bind time using the above procedure. --- guix/profiles.scm | 4 ++++ guix/store.scm | 7 +++++++ 2 files changed, 11 insertions(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 5b3b5bd5fe..0d38b2513f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2017 Huang Ying ;;; Copyright © 2017 Maxim Cournoyer ;;; Copyright © 2019 Kyle Meyer +;;; Copyright © 2019 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -1463,6 +1464,9 @@ are cross-built for TARGET." (mlet* %store-monad ((system (if system (return system) (current-system))) + (target (if target + (return target) + (current-target-system))) (ok? (if allow-collisions? (return #t) (check-for-collisions manifest system diff --git a/guix/store.scm b/guix/store.scm index cf25d347fc..f99fa581a8 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Jan Nieuwenhuizen +;;; Copyright © 2019 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -159,6 +160,7 @@ %guile-for-build current-system set-current-system + current-target-system text-file interned-file interned-file-tree @@ -1816,6 +1818,11 @@ the store." (lambda (state) (values (%current-system system) state))) +(define-inlinable (current-target-system) + ;; Consult the %CURRENT-TARGET-SYSTEM fluid at bind time. + (lambda (state) + (values (%current-target-system) state))) + (define %guile-for-build ;; The derivation of the Guile to be used within the build environment, ;; when using 'gexp->derivation' and co. -- cgit v1.2.3