diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/cache.scm | 9 | ||||
| -rw-r--r-- | guix/git.scm | 44 | ||||
| -rw-r--r-- | guix/import/cpan.scm | 3 | ||||
| -rw-r--r-- | guix/import/cran.scm | 8 | ||||
| -rw-r--r-- | guix/import/gem.scm | 5 | ||||
| -rw-r--r-- | guix/import/texlive.scm | 28 | ||||
| -rw-r--r-- | guix/licenses.scm | 10 | ||||
| -rw-r--r-- | guix/modules.scm | 4 | ||||
| -rw-r--r-- | guix/narinfo.scm | 326 | ||||
| -rw-r--r-- | guix/packages.scm | 38 | ||||
| -rw-r--r-- | guix/repl.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 31 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 298 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 1 | ||||
| -rw-r--r-- | guix/self.scm | 6 | ||||
| -rw-r--r-- | guix/serialization.scm | 16 | ||||
| -rw-r--r-- | guix/store.scm | 17 | ||||
| -rw-r--r-- | guix/swh.scm | 3 | ||||
| -rw-r--r-- | guix/transformations.scm | 49 | ||||
| -rw-r--r-- | guix/upstream.scm | 28 | ||||
| -rw-r--r-- | guix/utils.scm | 23 |
25 files changed, 601 insertions, 384 deletions
diff --git a/guix/cache.scm b/guix/cache.scm index feff131068..0401a9d428 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,13 +47,14 @@ (unless (= ENOENT (system-error-errno args)) (apply throw args))))) -(define (file-expiration-time ttl) +(define* (file-expiration-time ttl #:optional (timestamp stat:atime)) "Return a procedure that, when passed a file, returns its \"expiration -time\" computed as its last-access time + TTL seconds." +time\" computed as its timestamp + TTL seconds. Call TIMESTAMP to obtain the +relevant timestamp from the result of 'stat'." (lambda (file) (match (stat file #f) (#f 0) ;FILE may have been deleted in the meantime - (st (+ (stat:atime st) ttl))))) + (st (+ (timestamp st) ttl))))) (define* (remove-expired-cache-entries entries #:key diff --git a/guix/git.scm b/guix/git.scm index ca77b9f54b..a5103547d3 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,8 +23,10 @@ #:use-module (git submodule) #:use-module (guix i18n) #:use-module (guix base32) + #:use-module (guix cache) #:use-module (gcrypt hash) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) + #:select (mkdir-p delete-file-recursively)) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix records) @@ -35,6 +37,7 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) @@ -318,6 +321,24 @@ definitely available in REPOSITORY, false otherwise." (_ #f))) +(define cached-checkout-expiration + ;; Return the expiration time procedure for a cached checkout. + ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION. + + ;; Use the mtime rather than the atime to cope with file systems mounted + ;; with 'noatime'. + (file-expiration-time (* 90 24 3600) stat:mtime)) + +(define %checkout-cache-cleanup-period + ;; Period for the removal of expired cached checkouts. + (* 5 24 3600)) + +(define (delete-checkout directory) + "Delete DIRECTORY recursively, in an atomic fashion." + (let ((trashed (string-append directory ".trashed"))) + (rename-file directory trashed) + (delete-file-recursively trashed))) + (define* (update-cached-checkout url #:key (ref '(branch . "master")) @@ -341,6 +362,14 @@ When RECURSIVE? is true, check out submodules as well, if any. When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave it unchanged." + (define (cache-entries directory) + (filter-map (match-lambda + ((or "." "..") + #f) + (file + (string-append directory "/" file))) + (or (scandir directory) '()))) + (define canonical-ref ;; We used to require callers to specify "origin/" for each branch, which ;; made little sense since the cache should be transparent to them. So @@ -387,6 +416,17 @@ it unchanged." ;; REPOSITORY as soon as possible. (repository-close! repository) + ;; When CACHE-DIRECTORY is a sub-directory of the default cache + ;; directory, remove expired checkouts that are next to it. + (let ((parent (dirname cache-directory))) + (when (string=? parent (%repository-cache-directory)) + (maybe-remove-expired-cache-entries parent cache-entries + #:entry-expiration + cached-checkout-expiration + #:delete-entry delete-checkout + #:cleanup-period + %checkout-cache-cleanup-period))) + (values cache-directory (oid->string oid) relation))))) (define* (latest-repository-commit store url diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 514417f781..87abe9c2f1 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,6 +109,7 @@ (home-page cpan-release-home-page "resources" (match-lambda (#f #f) + ((? unspecified?) #f) ((lst ...) (assoc-ref lst "homepage")))) (dependencies cpan-release-dependencies "dependency" (lambda (vector) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index fd44d80915..e8caf080fd 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> @@ -341,7 +341,11 @@ empty list when the FIELD cannot be found." ;; The field for system dependencies is often abused to specify non-package ;; dependencies (such as c++11). This list is used to ignore them. (define invalid-packages - (list "c++11")) + (list "c++11" + "c++14" + "linux" + "getopt::long" + "xquartz")) (define cran-guix-name (cut guix-name "r-" <>)) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 1f6f94532e..418d716be6 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. @@ -49,6 +49,7 @@ ;; This is sometimes #nil (the JSON 'null' value). Arrange ;; to always return a list. (cond ((not licenses) '()) + ((unspecified? licenses) '()) ((vector? licenses) (vector->list licenses)) (else '())))) (info gem-info) @@ -69,7 +70,7 @@ json->gem-dependency-list)) (define (json->gem-dependency-list vector) - (if vector + (if (and vector (not (unspecified? vector))) (map json->gem-dependency (vector->list vector)) '())) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index a84683ef6f..18d8b95ee0 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,8 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (web uri) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (guix http-client) #:use-module (gcrypt hash) #:use-module (guix memoization) @@ -149,19 +152,24 @@ expression describing it." (home-page (string-append "http://www.ctan.org/pkg/" id)) (ref (texlive-ref component id)) (checkout (download-svn-to-store store ref))) + (unless checkout + (warning (G_ "Could not determine source location. \ +Please manually specify the source field.~%"))) `(package (name ,(guix-name component id)) (version ,version) - (source (origin - (method svn-fetch) - (uri (texlive-ref ,component ,id)) - (sha256 - (base32 - ,(bytevector->nix-base32-string - (let-values (((port get-hash) (open-sha256-port))) - (write-file checkout port) - (force-output port) - (get-hash))))))) + (source ,(if checkout + `(origin + (method svn-fetch) + (uri (texlive-ref ,component ,id)) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file checkout port) + (force-output port) + (get-hash)))))) + #f)) (build-system texlive-build-system) (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) (home-page ,home-page) diff --git a/guix/licenses.scm b/guix/licenses.scm index 255b755e6c..63010a7231 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -78,7 +78,7 @@ mpl1.0 mpl1.1 mpl2.0 ms-pl ncsa - npsl + nmap ogl-psi1.0 openldap2.8 openssl perl-license @@ -531,10 +531,10 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:IllinoisNCSA" "https://www.gnu.org/licenses/license-list#NCSA")) -(define npsl - (license "Nmap Public Source License" - "https://svn.nmap.org/nmap/LICENSE" - "https://nmap.org/npsl/")) +(define nmap + (license "Nmap license" + "https://svn.nmap.org/nmap/COPYING" + "https://fedoraproject.org/wiki/Licensing/Nmap")) (define ogl-psi1.0 (license "Open Government Licence for Public Sector Information" diff --git a/guix/modules.scm b/guix/modules.scm index 1a6fafe35b..61bc8e1978 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -77,7 +77,7 @@ CLAUSES." ((#:autoload module _ rest ...) (loop rest (cons module result))) (((or #:export #:re-export #:export-syntax #:re-export-syntax - #:replace #:version) + #:re-export-and-replace #:replace #:version) _ rest ...) (loop rest result)) (((or #:pure #:no-backtrace) rest ...) diff --git a/guix/narinfo.scm b/guix/narinfo.scm new file mode 100644 index 0000000000..241090ec98 --- /dev/null +++ b/guix/narinfo.scm @@ -0,0 +1,326 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix narinfo) + #:use-module (guix pki) + #:use-module (guix i18n) + #:use-module (guix base32) + #:use-module (guix base64) + #:use-module (guix records) + #:use-module (guix diagnostics) + #:use-module (guix scripts substitute) + #:use-module (gcrypt hash) + #:use-module (gcrypt pk-crypto) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) + #:use-module (web uri) + #:export (narinfo-signature->canonical-sexp + + narinfo? + narinfo-path + narinfo-uris + narinfo-uri-base + narinfo-compressions + narinfo-file-hashes + narinfo-file-sizes + narinfo-hash + narinfo-size + narinfo-references + narinfo-deriver + narinfo-system + narinfo-signature + + narinfo-hash-algorithm+value + + narinfo-hash->sha256 + narinfo-best-uri + + valid-narinfo? + + read-narinfo + write-narinfo + + string->narinfo + narinfo->string + + equivalent-narinfo?)) + +(define-record-type <narinfo> + (%make-narinfo path uri-base uris compressions file-sizes file-hashes + nar-hash nar-size references deriver system + signature contents) + narinfo? + (path narinfo-path) + (uri-base narinfo-uri-base) ;URI of the cache it originates from + (uris narinfo-uris) ;list of strings + (compressions narinfo-compressions) ;list of strings + (file-sizes narinfo-file-sizes) ;list of (integers | #f) + (file-hashes narinfo-file-hashes) + (nar-hash narinfo-hash) + (nar-size narinfo-size) + (references narinfo-references) + (deriver narinfo-deriver) + (system narinfo-system) + (signature narinfo-signature) ; canonical sexp + ;; The original contents of a narinfo file. This field is needed because we + ;; want to preserve the exact textual representation for verification purposes. + ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> + ;; for more information. + (contents narinfo-contents)) + +(define (narinfo-hash-algorithm+value narinfo) + "Return two values: the hash algorithm used by NARINFO and its value as a +bytevector." + (match (string-tokenize (narinfo-hash narinfo) + (char-set-complement (char-set #\:))) + ((algorithm base32) + (values (lookup-hash-algorithm (string->symbol algorithm)) + (nix-base32-string->bytevector base32))) + (_ + (raise (formatted-message + (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo)))))) + +(define (narinfo-hash->sha256 hash) + "If the string HASH denotes a sha256 hash, return it as a bytevector. +Otherwise return #f." + (and (string-prefix? "sha256:" hash) + (nix-base32-string->bytevector (string-drop hash 7)))) + +(define (narinfo-signature->canonical-sexp str) + "Return the value of a narinfo's 'Signature' field as a canonical sexp." + (match (string-split str #\;) + ((version host-name sig) + (let ((maybe-number (string->number version))) + (cond ((not (number? maybe-number)) + (leave (G_ "signature version must be a number: ~s~%") + version)) + ;; Currently, there are no other versions. + ((not (= 1 maybe-number)) + (leave (G_ "unsupported signature version: ~a~%") + maybe-number)) + (else + (let ((signature (utf8->string (base64-decode sig)))) + (catch 'gcry-error + (lambda () + (string->canonical-sexp signature)) + (lambda (key proc err) + (leave (G_ "signature is not a valid \ +s-expression: ~s~%") + signature)))))))) + (x + (leave (G_ "invalid format of the signature field: ~a~%") x)))) + +(define (narinfo-maker str cache-url) + "Return a narinfo constructor for narinfos originating from CACHE-URL. STR +must contain the original contents of a narinfo file." + (lambda (path urls compressions file-hashes file-sizes + nar-hash nar-size references deriver system + signature) + "Return a new <narinfo> object." + (define len (length urls)) + (%make-narinfo path cache-url + ;; Handle the case where URL is a relative URL. + (map (lambda (url) + (or (string->uri url) + (string->uri + (string-append cache-url "/" url)))) + urls) + compressions + (match file-sizes + (() (make-list len #f)) + ((lst ...) (map string->number lst))) + (match file-hashes + (() (make-list len #f)) + ((lst ...) (map string->number lst))) + nar-hash + (and=> nar-size string->number) + (string-tokenize references) + (match deriver + ((or #f "") #f) + (_ deriver)) + system + (false-if-exception + (and=> signature narinfo-signature->canonical-sexp)) + str))) + +(define fields->alist + ;; The narinfo format is really just like recutils. + recutils->alist) + +(define* (read-narinfo port #:optional url + #:key size) + "Read a narinfo from PORT. If URL is true, it must be a string used to +build full URIs from relative URIs found while reading PORT. When SIZE is +true, read at most SIZE bytes from PORT; otherwise, read as much as possible. + +No authentication and authorization checks are performed here!" + (let ((str (utf8->string (if size + (get-bytevector-n port size) + (get-bytevector-all port))))) + (alist->record (call-with-input-string str fields->alist) + (narinfo-maker str url) + '("StorePath" "URL" "Compression" + "FileHash" "FileSize" "NarHash" "NarSize" + "References" "Deriver" "System" + "Signature") + '("URL" "Compression" "FileSize" "FileHash")))) + +(define (narinfo-sha256 narinfo) + "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a +'Signature' field." + (define %mandatory-fields + ;; List of fields that must be signed. If they are not signed, the + ;; narinfo is considered unsigned. + '("StorePath" "NarHash" "References")) + + (let ((contents (narinfo-contents narinfo))) + (match (string-contains contents "Signature:") + (#f #f) + (index + (let* ((above-signature (string-take contents index)) + (signed-fields (match (call-with-input-string above-signature + fields->alist) + (((fields . values) ...) fields)))) + (and (every (cut member <> signed-fields) %mandatory-fields) + (sha256 (string->utf8 above-signature)))))))) + +(define* (valid-narinfo? narinfo #:optional (acl (current-acl)) + #:key verbose?) + "Return #t if NARINFO's signature is not valid." + (let ((hash (narinfo-sha256 narinfo)) + (signature (narinfo-signature narinfo)) + (uri (uri->string (first (narinfo-uris narinfo))))) + (and hash signature + (signature-case (signature hash acl) + (valid-signature #t) + (invalid-signature + (when verbose? + (format (current-error-port) + "invalid signature for substitute at '~a'~%" + uri)) + #f) + (hash-mismatch + (when verbose? + (format (current-error-port) + "hash mismatch for substitute at '~a'~%" + uri)) + #f) + (unauthorized-key + (when verbose? + (format (current-error-port) + "substitute at '~a' is signed by an \ +unauthorized party~%" + uri)) + #f) + (corrupt-signature + (when verbose? + (format (current-error-port) + "corrupt signature for substitute at '~a'~%" + uri)) + #f))))) + +(define (write-narinfo narinfo port) + "Write NARINFO to PORT." + (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) + +(define (narinfo->string narinfo) + "Return the external representation of NARINFO." + (call-with-output-string (cut write-narinfo narinfo <>))) + +(define (string->narinfo str cache-uri) + "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of +the cache STR originates form." + (call-with-input-string str (cut read-narinfo <> cache-uri))) + +(define (equivalent-narinfo? narinfo1 narinfo2) + "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe +the same store item. This ignores unnecessary metadata such as the Nar URL." + (and (string=? (narinfo-hash narinfo1) + (narinfo-hash narinfo2)) + + ;; The following is not needed if all we want is to download a valid + ;; nar, but it's necessary if we want valid narinfo. + (string=? (narinfo-path narinfo1) + (narinfo-path narinfo2)) + (equal? (narinfo-references narinfo1) + (narinfo-references narinfo2)) + + (= (narinfo-size narinfo1) + (narinfo-size narinfo2)))) + +(define %compression-methods + ;; Known compression methods and a thunk to determine whether they're + ;; supported. See 'decompressed-port' in (guix utils). + `(("gzip" . ,(const #t)) + ("lzip" . ,(const #t)) + ("zstd" . ,(lambda () + (resolve-module '(zstd) #t #f #:ensure #f))) + ("xz" . ,(const #t)) + ("bzip2" . ,(const #t)) + ("none" . ,(const #t)))) + +(define (supported-compression? compression) + "Return true if COMPRESSION, a string, denotes a supported compression +method." + (match (assoc-ref %compression-methods compression) + (#f #f) + (supported? (supported?)))) + +(define (compresses-better? compression1 compression2) + "Return true if COMPRESSION1 generally compresses better than COMPRESSION2; +this is a rough approximation." + (match compression1 + ("none" #f) + ("gzip" (string=? compression2 "none")) + ("lzip" #t) + (_ (or (string=? compression2 "none") + (string=? compression2 "gzip"))))) + +(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 + (filter (match-lambda + ((uri compression file-size) + (supported-compression? compression))) + (zip (narinfo-uris narinfo) + (narinfo-compressions narinfo) + (narinfo-file-sizes narinfo)))) + + (define (file-size<? c1 c2) + (match c1 + ((uri1 compression1 (? integer? file-size1)) + (match c2 + ((uri2 compression2 (? integer? file-size2)) + (< file-size1 file-size2)) + (_ #t))) + ((uri compression1 #f) + (match c2 + ((uri2 compression2 _) + (compresses-better? compression1 compression2)))) + (_ #f))) ;we can't tell + + (match (sort choices file-size<?) + (((uri compression file-size) _ ...) + (values uri compression file-size)))) diff --git a/guix/packages.scm b/guix/packages.scm index 6fa761f569..9305dabcec 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -167,6 +167,25 @@ ;;; ;;; Code: +(define-syntax-rule (define-compile-time-decoder name string->bytevector) + "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time +if possible." + (define-syntax name + (lambda (s) + "Return the bytevector corresponding to the given textual +representation." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + ;; A literal string: do the conversion at expansion time. + (with-syntax ((bv (string->bytevector (syntax->datum #'str)))) + #''bv)) + ((_ str) + #'(string->bytevector str)))))) + +(define-compile-time-decoder base32 nix-base32-string->bytevector) +(define-compile-time-decoder base64 base64-decode) + ;; Crytographic content hash. (define-immutable-record-type <content-hash> (%content-hash algorithm value) @@ -302,25 +321,6 @@ specifications to 'hash'." (set-record-type-printer! <origin> print-origin) -(define-syntax-rule (define-compile-time-decoder name string->bytevector) - "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time -if possible." - (define-syntax name - (lambda (s) - "Return the bytevector corresponding to the given textual -representation." - (syntax-case s () - ((_ str) - (string? (syntax->datum #'str)) - ;; A literal string: do the conversion at expansion time. - (with-syntax ((bv (string->bytevector (syntax->datum #'str)))) - #''bv)) - ((_ str) - #'(string->bytevector str)))))) - -(define-compile-time-decoder base32 nix-base32-string->bytevector) -(define-compile-time-decoder base64 base64-decode) - (define (origin-actual-file-name origin) "Return the file name of ORIGIN, either its 'file-name' field or the file name of its URI." diff --git a/guix/repl.scm b/guix/repl.scm index 0ace5976cf..94d85815ef 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -78,8 +78,14 @@ output port. VERSION is the client's protocol version we are targeting." (let ((stack (if (repl-prompt) (make-stack #t handle-exception (repl-prompt)) (make-stack #t)))) + ;; Note: 'make-stack' returns #f if there's no 'handle-exception' + ;; stack frame, which is the case when this file is being + ;; interpreted as with 'primitive-load'. `(exception (arguments ,key ,@(map value->sexp args)) - (stack ,@(map frame->sexp (stack->frames stack)))))) + (stack ,@(map frame->sexp + (if stack + (stack->frames stack) + '())))))) (_ ;; Protocol (0 0). `(exception ,key ,@(map value->sexp args))))) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 1f73fff711..91be1b02e1 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -318,8 +318,8 @@ the input port." (warning (G_ "replacing symbolic link ~a with a regular file~%") %acl-file) (when (string-prefix? (%store-prefix) (readlink %acl-file)) - (display-hint (G_ "On Guix System, add public keys to the -@code{authorized-keys} field of your @code{operating-system} instead."))))) + (display-hint (G_ "On Guix System, add all @code{authorized-keys} to the +@code{guix-service-type} service of your @code{operating-system} instead."))))) (let ((key (read-key)) (acl (current-acl))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index d0a456ac1d..cc9cbe6f27 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -28,6 +28,7 @@ #:use-module ((guix progress) #:hide (dump-port*)) #:use-module (guix serialization) #:use-module (guix scripts substitute) + #:use-module (guix narinfo) #:use-module (rnrs bytevectors) #:autoload (guix http-client) (http-fetch) #:use-module ((guix build syscalls) #:select (terminal-columns)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index fbc202c658..f4d12f89bf 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -675,7 +675,7 @@ message if any test fails." (let* ((root (if (string-prefix? "/" root) root (string-append (canonicalize-path (dirname root)) - "/" root)))) + "/" (basename root))))) (catch 'system-error (lambda () (symlink target root) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 5a865c838d..fa85088ed0 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -56,6 +56,8 @@ #:use-module (zlib) #:autoload (lzlib) (call-with-lzip-output-port make-lzip-output-port) + #:autoload (zstd) (call-with-zstd-output-port + make-zstd-output-port) #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) @@ -588,23 +590,22 @@ requested using POOL." (define nar (nar-cache-file cache item #:compression compression)) + (define (write-compressed-file call-with-compressed-output-port) + ;; Note: the file port gets closed along with the compressed port. + (call-with-compressed-output-port (open-output-file (string-append nar ".tmp")) + (lambda (port) + (write-file item port)) + #:level (compression-level compression)) + (rename-file (string-append nar ".tmp") nar)) + (mkdir-p (dirname nar)) (match (compression-type compression) ('gzip - ;; Note: the file port gets closed along with the gzip port. - (call-with-gzip-output-port (open-output-file (string-append nar ".tmp")) - (lambda (port) - (write-file item port)) - #:level (compression-level compression) - #:buffer-size %default-buffer-size) - (rename-file (string-append nar ".tmp") nar)) + (write-compressed-file call-with-gzip-output-port)) ('lzip - ;; Note: the file port gets closed along with the lzip port. - (call-with-lzip-output-port (open-output-file (string-append nar ".tmp")) - (lambda (port) - (write-file item port)) - #:level (compression-level compression)) - (rename-file (string-append nar ".tmp") nar)) + (write-compressed-file call-with-lzip-output-port)) + ('zstd + (write-compressed-file call-with-zstd-output-port)) ('none ;; Cache nars even when compression is disabled so that we can ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.) @@ -871,6 +872,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (($ <compression> 'lzip level) (make-lzip-output-port (response-port response) #:level level)) + (($ <compression> 'zstd level) + (make-zstd-output-port (response-port response) + #:level level)) (($ <compression> 'none) (response-port response)) (#f @@ -953,6 +957,7 @@ blocking." (match string ("gzip" 'gzip) ("lzip" 'lzip) + ("zstd" 'zstd) (_ #f))) (define (effective-compression requested-type compressions) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index e53de8c304..f9bcead045 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix narinfo) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix combinators) @@ -67,29 +69,8 @@ #:use-module (web request) #:use-module (web response) #:use-module (guix http-client) - #:export (narinfo-signature->canonical-sexp - - narinfo? - narinfo-path - narinfo-uris - narinfo-uri-base - narinfo-compressions - narinfo-file-hashes - narinfo-file-sizes - narinfo-hash - narinfo-size - narinfo-references - narinfo-deriver - narinfo-system - narinfo-signature - - narinfo-hash->sha256 - narinfo-best-uri - - lookup-narinfos + #:export (lookup-narinfos lookup-narinfos/diverse - read-narinfo - write-narinfo %allow-unauthenticated-substitutes? %error-to-file-descriptor-4? @@ -149,10 +130,6 @@ disabled!~%")) ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) -(define fields->alist - ;; The narinfo format is really just like recutils. - recutils->alist) - (define %fetch-timeout ;; Number of seconds after which networking is considered "slow". 5) @@ -236,191 +213,6 @@ connection (typically PORT) is kept open once data has been fetched from URI." (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) - -(define-record-type <narinfo> - (%make-narinfo path uri-base uris compressions file-sizes file-hashes - nar-hash nar-size references deriver system - signature contents) - narinfo? - (path narinfo-path) - (uri-base narinfo-uri-base) ;URI of the cache it originates from - (uris narinfo-uris) ;list of strings - (compressions narinfo-compressions) ;list of strings - (file-sizes narinfo-file-sizes) ;list of (integers | #f) - (file-hashes narinfo-file-hashes) - (nar-hash narinfo-hash) - (nar-size narinfo-size) - (references narinfo-references) - (deriver narinfo-deriver) - (system narinfo-system) - (signature narinfo-signature) ; canonical sexp - ;; The original contents of a narinfo file. This field is needed because we - ;; want to preserve the exact textual representation for verification purposes. - ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> - ;; for more information. - (contents narinfo-contents)) - -(define (narinfo-hash-algorithm+value narinfo) - "Return two values: the hash algorithm used by NARINFO and its value as a -bytevector." - (match (string-tokenize (narinfo-hash narinfo) - (char-set-complement (char-set #\:))) - ((algorithm base32) - (values (lookup-hash-algorithm (string->symbol algorithm)) - (nix-base32-string->bytevector base32))) - (_ - (raise (formatted-message - (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo)))))) - -(define (narinfo-hash->sha256 hash) - "If the string HASH denotes a sha256 hash, return it as a bytevector. -Otherwise return #f." - (and (string-prefix? "sha256:" hash) - (nix-base32-string->bytevector (string-drop hash 7)))) - -(define (narinfo-signature->canonical-sexp str) - "Return the value of a narinfo's 'Signature' field as a canonical sexp." - (match (string-split str #\;) - ((version host-name sig) - (let ((maybe-number (string->number version))) - (cond ((not (number? maybe-number)) - (leave (G_ "signature version must be a number: ~s~%") - version)) - ;; Currently, there are no other versions. - ((not (= 1 maybe-number)) - (leave (G_ "unsupported signature version: ~a~%") - maybe-number)) - (else - (let ((signature (utf8->string (base64-decode sig)))) - (catch 'gcry-error - (lambda () - (string->canonical-sexp signature)) - (lambda (key proc err) - (leave (G_ "signature is not a valid \ -s-expression: ~s~%") - signature)))))))) - (x - (leave (G_ "invalid format of the signature field: ~a~%") x)))) - -(define (narinfo-maker str cache-url) - "Return a narinfo constructor for narinfos originating from CACHE-URL. STR -must contain the original contents of a narinfo file." - (lambda (path urls compressions file-hashes file-sizes - nar-hash nar-size references deriver system - signature) - "Return a new <narinfo> object." - (define len (length urls)) - (%make-narinfo path cache-url - ;; Handle the case where URL is a relative URL. - (map (lambda (url) - (or (string->uri url) - (string->uri - (string-append cache-url "/" url)))) - urls) - compressions - (match file-sizes - (() (make-list len #f)) - ((lst ...) (map string->number lst))) - (match file-hashes - (() (make-list len #f)) - ((lst ...) (map string->number lst))) - nar-hash - (and=> nar-size string->number) - (string-tokenize references) - (match deriver - ((or #f "") #f) - (_ deriver)) - system - (false-if-exception - (and=> signature narinfo-signature->canonical-sexp)) - str))) - -(define* (read-narinfo port #:optional url - #:key size) - "Read a narinfo from PORT. If URL is true, it must be a string used to -build full URIs from relative URIs found while reading PORT. When SIZE is -true, read at most SIZE bytes from PORT; otherwise, read as much as possible. - -No authentication and authorization checks are performed here!" - (let ((str (utf8->string (if size - (get-bytevector-n port size) - (get-bytevector-all port))))) - (alist->record (call-with-input-string str fields->alist) - (narinfo-maker str url) - '("StorePath" "URL" "Compression" - "FileHash" "FileSize" "NarHash" "NarSize" - "References" "Deriver" "System" - "Signature") - '("URL" "Compression" "FileSize" "FileHash")))) - -(define (narinfo-sha256 narinfo) - "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a -'Signature' field." - (define %mandatory-fields - ;; List of fields that must be signed. If they are not signed, the - ;; narinfo is considered unsigned. - '("StorePath" "NarHash" "References")) - - (let ((contents (narinfo-contents narinfo))) - (match (string-contains contents "Signature:") - (#f #f) - (index - (let* ((above-signature (string-take contents index)) - (signed-fields (match (call-with-input-string above-signature - fields->alist) - (((fields . values) ...) fields)))) - (and (every (cut member <> signed-fields) %mandatory-fields) - (sha256 (string->utf8 above-signature)))))))) - -(define* (valid-narinfo? narinfo #:optional (acl (current-acl)) - #:key verbose?) - "Return #t if NARINFO's signature is not valid." - (or (%allow-unauthenticated-substitutes?) - (let ((hash (narinfo-sha256 narinfo)) - (signature (narinfo-signature narinfo)) - (uri (uri->string (first (narinfo-uris narinfo))))) - (and hash signature - (signature-case (signature hash acl) - (valid-signature #t) - (invalid-signature - (when verbose? - (format (current-error-port) - "invalid signature for substitute at '~a'~%" - uri)) - #f) - (hash-mismatch - (when verbose? - (format (current-error-port) - "hash mismatch for substitute at '~a'~%" - uri)) - #f) - (unauthorized-key - (when verbose? - (format (current-error-port) - "substitute at '~a' is signed by an \ -unauthorized party~%" - uri)) - #f) - (corrupt-signature - (when verbose? - (format (current-error-port) - "corrupt signature for substitute at '~a'~%" - uri)) - #f)))))) - -(define (write-narinfo narinfo port) - "Write NARINFO to PORT." - (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) - -(define (narinfo->string narinfo) - "Return the external representation of NARINFO." - (call-with-output-string (cut write-narinfo narinfo <>))) - -(define (string->narinfo str cache-uri) - "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of -the cache STR originates form." - (call-with-input-string str (cut read-narinfo <> cache-uri))) - (define (narinfo-cache-file cache-url path) "Return the name of the local file that contains an entry for PATH. The entry is stored in a sub-directory specific to CACHE-URL." @@ -742,22 +534,6 @@ information is available locally." (let ((missing (fetch-narinfos cache missing))) (append cached (or missing '())))))) -(define (equivalent-narinfo? narinfo1 narinfo2) - "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe -the same store item. This ignores unnecessary metadata such as the Nar URL." - (and (string=? (narinfo-hash narinfo1) - (narinfo-hash narinfo2)) - - ;; The following is not needed if all we want is to download a valid - ;; nar, but it's necessary if we want valid narinfo. - (string=? (narinfo-path narinfo1) - (narinfo-path narinfo2)) - (equal? (narinfo-references narinfo1) - (narinfo-references narinfo2)) - - (= (narinfo-size narinfo1) - (narinfo-size narinfo2)))) - (define (lookup-narinfos/diverse caches paths authorized?) "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next @@ -918,11 +694,14 @@ expected by the daemon." "Reply to COMMAND, a query as written by the daemon to this process's standard input. Use ACL as the access-control list against which to check authorized substitutes." - (define (valid? obj) - (valid-narinfo? obj acl)) + (define valid? + (if (%allow-unauthenticated-substitutes?) + (begin + (warn-about-missing-authentication) - (when (%allow-unauthenticated-substitutes?) - (warn-about-missing-authentication)) + (const #t)) + (lambda (obj) + (valid-narinfo? obj acl)))) (match (string-tokenize command) (("have" paths ..1) @@ -940,59 +719,6 @@ authorized substitutes." (wtf (error "unknown `--query' command" wtf)))) -(define %compression-methods - ;; Known compression methods and a thunk to determine whether they're - ;; supported. See 'decompressed-port' in (guix utils). - `(("gzip" . ,(const #t)) - ("lzip" . ,(const #t)) - ("xz" . ,(const #t)) - ("bzip2" . ,(const #t)) - ("none" . ,(const #t)))) - -(define (supported-compression? compression) - "Return true if COMPRESSION, a string, denotes a supported compression -method." - (match (assoc-ref %compression-methods compression) - (#f #f) - (supported? (supported?)))) - -(define (compresses-better? compression1 compression2) - "Return true if COMPRESSION1 generally compresses better than COMPRESSION2; -this is a rough approximation." - (match compression1 - ("none" #f) - ("gzip" (string=? compression2 "none")) - (_ (or (string=? compression2 "none") - (string=? compression2 "gzip"))))) - -(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 - (filter (match-lambda - ((uri compression file-size) - (supported-compression? compression))) - (zip (narinfo-uris narinfo) - (narinfo-compressions narinfo) - (narinfo-file-sizes narinfo)))) - - (define (file-size<? c1 c2) - (match c1 - ((uri1 compression1 (? integer? file-size1)) - (match c2 - ((uri2 compression2 (? integer? file-size2)) - (< file-size1 file-size2)) - (_ #t))) - ((uri compression1 #f) - (match c2 - ((uri2 compression2 _) - (compresses-better? compression1 compression2)))) - (_ #f))) ;we can't tell - - (match (sort choices file-size<?) - (((uri compression file-size) _ ...) - (values uri compression file-size)))) - (define %max-cached-connections ;; Maximum number of connections kept in cache by ;; 'open-connection-for-uri/cached'. @@ -1079,7 +805,9 @@ DESTINATION is in the store, deduplicate its files. Print a status line on the current output port." (define narinfo (lookup-narinfo cache-urls store-item - (cut valid-narinfo? <> acl))) + (if (%allow-unauthenticated-substitutes?) + (const #t) + (cut valid-narinfo? <> acl)))) (define destination-in-store? (string-prefix? (string-append (%store-prefix) "/") diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 51c8cf2f76..66225bff35 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -705,9 +705,11 @@ checking this by themselves in their 'check' procedure." image-size (* 70 (expt 2 20))) #:mappings mappings)) - ((disk-image) + ((image disk-image) (let* ((base-image (os->image os #:type image-type)) (base-target (image-target base-image))) + (when (eq? action 'disk-image) + (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) (lower-object (system-image (image @@ -779,7 +781,7 @@ and TARGET arguments." "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for -the 'vm-image' and 'disk-image' actions. IMAGE-TYPE is the type of image to +the 'vm-image' and 'image' actions. IMAGE-TYPE is the type of image to be built. When VOLATILE-ROOT? is #t, the root file system is mounted volatile. @@ -968,7 +970,7 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ vm-image build a freestanding virtual machine image\n")) (display (G_ "\ - disk-image build a disk image, suitable for a USB stick\n")) + image build a Guix System image\n")) (display (G_ "\ docker-image build a Docker image\n")) (display (G_ "\ @@ -994,15 +996,15 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --list-image-types list available image types")) (display (G_ " - -t, --image-type=TYPE for 'disk-image', produce an image of TYPE")) + -t, --image-type=TYPE for 'image', produce an image of TYPE")) (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) (display (G_ " - --volatile for 'disk-image', make the root file system volatile")) + --volatile for 'image', make the root file system volatile")) (display (G_ " - --label=LABEL for 'disk-image', label disk image with LABEL")) + --label=LABEL for 'image', label disk image with LABEL")) (display (G_ " --save-provenance save provenance information")) (display (G_ " @@ -1014,7 +1016,7 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " -N, --network for 'container', allow containers to access the network")) (display (G_ " - -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', + -r, --root=FILE for 'vm', 'vm-image', 'image', 'container', and 'build', make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " @@ -1143,7 +1145,7 @@ Some ACTIONS support additional ARGS.\n")) (debug . 0) (verbosity . #f) ;default (validate-reconfigure . ,ensure-forward-reconfigure) - (image-type . raw) + (image-type . efi-raw) (image-size . guess) (install-bootloader? . #t) (label . #f) @@ -1335,7 +1337,7 @@ argument list and OPTS is the option alist." (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build container vm vm-image disk-image reconfigure init + ((build container vm vm-image image disk-image reconfigure init extension-graph shepherd-graph list-generations describe delete-generations roll-back @@ -1368,7 +1370,8 @@ argument list and OPTS is the option alist." (exit 1)) (case action - ((build container vm vm-image disk-image docker-image reconfigure) + ((build container vm vm-image image disk-image docker-image + reconfigure) (unless (or (= count 1) (and expr (= count 0))) (fail))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index f28070ddc4..97e4a73802 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -33,6 +33,7 @@ #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module ((guix build utils) #:select (every*)) #:use-module (guix scripts substitute) + #:use-module (guix narinfo) #:use-module (guix http-client) #:use-module (guix ci) #:use-module (guix sets) diff --git a/guix/self.scm b/guix/self.scm index e2e3198057..15c8ad4eb9 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -59,6 +59,7 @@ ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib)) ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) + ("guile-zstd" (ref '(gnu packages guile) 'guile-zstd)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'gnutls)) ("gzip" (ref '(gnu packages compression) 'gzip)) @@ -823,6 +824,9 @@ itself." (define guile-lzlib (specification->package "guile-lzlib")) + (define guile-zstd + (specification->package "guile-zstd")) + (define guile-gcrypt (specification->package "guile-gcrypt")) @@ -836,7 +840,7 @@ itself." (append-map transitive-package-dependencies (list guile-gcrypt gnutls guile-git guile-avahi guile-json guile-semver guile-ssh guile-sqlite3 - guile-zlib guile-lzlib))) + guile-zlib guile-lzlib guile-zstd))) (define *core-modules* (scheme-node "guix-core" diff --git a/guix/serialization.scm b/guix/serialization.scm index 59cd93fb18..9d0739f6c5 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,7 +34,7 @@ write-bytevector write-string read-string read-latin1-string read-maybe-utf8-string write-string-list read-string-list - write-string-pairs + write-string-pairs read-string-pairs write-store-path read-store-path write-store-path-list read-store-path-list (dump . dump-port*) @@ -166,6 +166,14 @@ substitute invalid byte sequences with question marks. This is a (write-int (length l) p) (for-each (cut write-string <> p) l)) +(define (read-string-list p) + (let ((len (read-int p))) + (unfold (cut >= <> len) + (lambda (i) + (read-string p)) + 1+ + 0))) + (define (write-string-pairs l p) (write-int (length l) p) (for-each (match-lambda @@ -174,11 +182,11 @@ substitute invalid byte sequences with question marks. This is a (write-string second p))) l)) -(define (read-string-list p) +(define (read-string-pairs p) (let ((len (read-int p))) (unfold (cut >= <> len) (lambda (i) - (read-string p)) + (cons (read-string p) (read-string p))) 1+ 0))) diff --git a/guix/store.scm b/guix/store.scm index 4da39971b5..e0b15abce3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de> @@ -114,6 +114,7 @@ query-failed-paths clear-failed-paths ensure-path + find-roots add-temp-root add-indirect-root add-permanent-root @@ -340,7 +341,8 @@ (write-string (bytevector->base16-string arg) p)))) (define-syntax read-arg - (syntax-rules (integer boolean string store-path store-path-list string-list + (syntax-rules (integer boolean string store-path + store-path-list string-list string-pairs substitutable-path-list path-info base16) ((_ integer p) (read-int p)) @@ -354,6 +356,8 @@ (read-store-path-list p)) ((_ string-list p) (read-string-list p)) + ((_ string-pairs p) + (read-string-pairs p)) ((_ substitutable-path-list p) (read-substitutable-path-list p)) ((_ path-info p) @@ -1404,6 +1408,15 @@ running a substitute. As a GC root is not created by the daemon, you may want to call ADD-TEMP-ROOT on that store path." boolean) +(define-operation (find-roots) + "Return a list of root/target pairs: for each pair, the first element is the +GC root file name and the second element is its target in the store. + +When talking to a local daemon, this operation is equivalent to the 'gc-roots' +procedure in (guix store roots), except that the 'find-roots' excludes +potential roots that do not point to store items." + string-pairs) + (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. Return #t." diff --git a/guix/swh.scm b/guix/swh.scm index 0b765cc743..f11b7ea2d5 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. @@ -348,6 +348,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." (checksums directory-entry-checksums "checksums" (match-lambda (#f #f) + ((? unspecified?) #f) (lst (json->checksums lst)))) (id directory-entry-id "dir_id") (length directory-entry-length) diff --git a/guix/transformations.scm b/guix/transformations.scm index 2385d3231e..4e9260350c 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +25,9 @@ #:autoload (guix download) (download-to-store) #:autoload (guix git-download) (git-reference? git-reference-url) #:autoload (guix git) (git-checkout git-checkout? git-checkout-url) + #:autoload (guix upstream) (package-latest-release* + upstream-source-version + upstream-source-signature-urls) #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix gexp) @@ -511,6 +514,42 @@ additional patches." (rewrite obj) obj))) +(define (transform-package-latest specs) + "Return a procedure that rewrites package graphs such that those in SPECS +are replaced by their latest upstream version." + (define (package-with-latest-upstream p) + (let ((source (package-latest-release* p))) + (cond ((not source) + (warning + (G_ "could not determine latest upstream release of '~a'~%") + (package-name p)) + p) + ((string=? (upstream-source-version source) + (package-version p)) + p) + (else + (unless (pair? (upstream-source-signature-urls source)) + (warning (G_ "cannot authenticate source of '~a', version ~a~%") + (package-name p) + (upstream-source-version source))) + + ;; TODO: Take 'upstream-source-input-changes' into account. + (package + (inherit p) + (version (upstream-source-version source)) + (source source)))))) + + (define rewrite + (package-input-rewriting/spec + (map (lambda (spec) + (cons spec package-with-latest-upstream)) + specs))) + + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -525,7 +564,8 @@ additional patches." (with-c-toolchain . ,transform-package-toolchain) (with-debug-info . ,transform-package-with-debug-info) (without-tests . ,transform-package-tests) - (with-patch . ,transform-package-patches))) + (with-patch . ,transform-package-patches) + (with-latest . ,transform-package-latest))) (define (transformation-procedure key) "Return the transformation procedure associated with KEY, a symbol such as @@ -567,6 +607,8 @@ additional patches." (parser 'without-tests)) (option '("with-patch") #t #f (parser 'with-patch)) + (option '("with-latest") #t #f + (parser 'with-latest)) (option '("help-transform") #f #f (lambda _ @@ -599,6 +641,9 @@ additional patches." --with-patch=PACKAGE=FILE add FILE to the list of patches of PACKAGE")) (display (G_ " + --with-latest=PACKAGE + use the latest upstream release of PACKAGE")) + (display (G_ " --with-c-toolchain=PACKAGE=TOOLCHAIN build PACKAGE and its dependents with TOOLCHAIN")) (display (G_ " diff --git a/guix/upstream.scm b/guix/upstream.scm index a8ed1d81cd..accd8967d8 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -31,8 +31,8 @@ #:use-module (guix base32) #:use-module (guix gexp) #:use-module (guix store) - #:use-module ((guix derivations) - #:select (built-derivations derivation->output-path)) + #:use-module ((guix derivations) #:select (built-derivations derivation->output-path)) + #:autoload (gcrypt hash) (port-sha256) #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -248,6 +248,9 @@ correspond to the same version." '() (importer-modules)))) +;; Tests need to mock this variable so mark it as "non-declarative". +(set! %updaters %updaters) + (define* (lookup-updater package #:optional (updaters (force %updaters))) "Return an updater among UPDATERS that matches PACKAGE, or #f if none of @@ -351,6 +354,27 @@ values: 'interactive' (default), 'always', and 'never'." data url) #f))))))) +(define-gexp-compiler (upstream-source-compiler (source <upstream-source>) + system target) + "Download SOURCE from its first URL and lower it as a fixed-output +derivation that would fetch it." + (mlet* %store-monad ((url -> (first (upstream-source-urls source))) + (signature + -> (and=> (upstream-source-signature-urls source) + first)) + (tarball ((store-lift download-tarball) url signature))) + (unless tarball + (raise (formatted-message (G_ "failed to fetch source from '~a'") + url))) + + ;; Instead of returning TARBALL, return a fixed-output derivation that + ;; would be able to re-download it. In practice, since TARBALL is already + ;; in the store, no extra download will happen, but having the derivation + ;; in store improves provenance tracking. + (let ((hash (call-with-input-file tarball port-sha256))) + (url-fetch url 'sha256 hash (store-path-package-name tarball) + #:system system)))) + (define (find2 pred lst1 lst2) "Like 'find', but operate on items from both LST1 and LST2. Return two values: the item from LST1 and the item from LST2 that match PRED." diff --git a/guix/utils.scm b/guix/utils.scm index 0df46f1062..f8b05e7e80 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -110,7 +110,6 @@ edit-expression filtered-port - compressed-port decompressed-port call-with-decompressed-port compressed-output-port @@ -211,7 +210,13 @@ buffered data is lost." "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. Raise an error if lzlib support is missing." (let ((make-port (module-ref (resolve-interface '(lzlib)) proc))) - (values (make-port port) '()))) + (make-port port))) + +(define (zstd-port proc port . args) + "Return the zstd port produced by calling PROC (a symbol) on PORT and ARGS. +Raise an error if zstd support is missing." + (let ((make-port (module-ref (resolve-interface '(zstd)) proc))) + (make-port port))) (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, @@ -223,17 +228,7 @@ a symbol such as 'xz." ('gzip (filtered-port `(,%gzip "-dc") input)) ('lzip (values (lzip-port 'make-lzip-input-port input) '())) - (_ (error "unsupported compression scheme" compression)))) - -(define (compressed-port compression input) - "Return an input port where INPUT is compressed according to COMPRESSION, -a symbol such as 'xz." - (match compression - ((or #f 'none) (values input '())) - ('bzip2 (filtered-port `(,%bzip2 "-c") input)) - ('xz (filtered-port `(,%xz "-c") input)) - ('gzip (filtered-port `(,%gzip "-c") input)) - ('lzip (values (lzip-port 'make-lzip-input-port/compressed input) + ('zstd (values (zstd-port 'make-zstd-input-port input) '())) (_ (error "unsupported compression scheme" compression)))) @@ -294,6 +289,8 @@ program--e.g., '(\"--fast\")." ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) ('lzip (values (lzip-port 'make-lzip-output-port output) '())) + ('zstd (values (zstd-port 'make-zstd-output-port output) + '())) (_ (error "unsupported compression scheme" compression)))) (define* (call-with-compressed-output-port compression port proc |