diff options
author | Marius Bakke <mbakke@fastmail.com> | 2020-01-21 22:39:42 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2020-01-21 22:39:42 +0100 |
commit | 8ed9be3faccb865204de46d2a8ed3e96e59281b6 (patch) | |
tree | 77ba4c90cda569048bc9ce2e414ede1567130c88 /guix | |
parent | 36930b2463fc933e7c5580f49413dbd14cf1df48 (diff) | |
parent | 715110a8a2e9e4b1a89635950744eb5260b8ee7f (diff) | |
download | patches-8ed9be3faccb865204de46d2a8ed3e96e59281b6.tar patches-8ed9be3faccb865204de46d2a8ed3e96e59281b6.tar.gz |
Merge branch 'staging' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/clojure-utils.scm | 15 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 4 | ||||
-rw-r--r-- | guix/import/cpan.scm | 161 | ||||
-rw-r--r-- | guix/import/cran.scm | 9 | ||||
-rw-r--r-- | guix/import/crate.scm | 3 | ||||
-rw-r--r-- | guix/import/elpa.scm | 5 | ||||
-rw-r--r-- | guix/import/opam.scm | 21 | ||||
-rw-r--r-- | guix/import/texlive.scm | 5 | ||||
-rw-r--r-- | guix/inferior.scm | 5 | ||||
-rw-r--r-- | guix/lint.scm | 24 | ||||
-rw-r--r-- | guix/lzlib.scm | 42 | ||||
-rw-r--r-- | guix/records.scm | 19 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 7 | ||||
-rw-r--r-- | guix/scripts/edit.scm | 10 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 8 | ||||
-rw-r--r-- | guix/scripts/package.scm | 21 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 4 | ||||
-rw-r--r-- | guix/scripts/refresh.scm | 18 | ||||
-rw-r--r-- | guix/scripts/repl.scm | 39 | ||||
-rw-r--r-- | guix/scripts/size.scm | 8 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
-rw-r--r-- | guix/serialization.scm | 3 | ||||
-rw-r--r-- | guix/ui.scm | 15 |
23 files changed, 318 insertions, 130 deletions
diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index 9f7334bc8d..a9ffad3c8f 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -69,10 +69,7 @@ (define-with-docs %doc-regex "Default regex for matching the base name of top-level documentation files." - (format #f - "(~a)|(\\.(html|markdown|md|txt)$)" - (@@ (guix build guile-build-system) - %documentation-file-regexp))) + "^(README.*|.*\\.html|.*\\.org|.*\\.md|\\.markdown|\\.txt)$") (define* (install-doc #:key doc-dirs @@ -185,10 +182,12 @@ canonicalized." (apply find-files "./" args)))) ;;; FIXME: should be moved to (guix build utils) -(define-with-docs file-sans-extension - "Strip extension from path, if any." - (@@ (guix build guile-build-system) - file-sans-extension)) +(define (file-sans-extension file) ;TODO: factorize + "Return the substring of FILE without its extension, if any." + (let ((dot (string-rindex file #\.))) + (if dot + (substring file 0 dot) + file))) (define (relative-path->clojure-lib-string path) "Convert PATH to a clojure library string." diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 248d6761fc..ae79a9708f 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -1140,7 +1140,7 @@ exception if it's already taken." ;; at this point. (if (= ENOSYS (system-error-errno (cons key args))) #f - (apply throw args))) + (apply throw key args))) (_ (apply throw key args))))))) (dynamic-wind (lambda () diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index ec86f11743..7a97c7f8e8 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -3,6 +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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,20 +28,42 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (json) + #:use-module (guix json) #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix base32) #:use-module (guix ui) #:use-module ((guix download) #:select (download-to-store url-fetch)) - #:use-module ((guix import utils) #:select (factorize-uri - flatten assoc-ref*)) + #:use-module ((guix import utils) #:select (factorize-uri)) #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix derivations) - #:export (cpan->guix-package - %cpan-updater)) + #:export (cpan-dependency? + cpan-dependency-relationship + cpan-dependency-phase + cpan-dependency-module + cpan-dependency-version + + cpan-release? + cpan-release-license + cpan-release-author + cpan-release-version + cpan-release-modle + cpan-release-distribution + cpan-release-download-url + cpan-release-abstract + cpan-release-home-page + cpan-release-dependencies + json->cpan-release + + cpan-fetch + cpan->guix-package + metacpan-url->mirror-url + %cpan-updater + + %metacpan-base-url)) ;;; Commentary: ;;; @@ -49,6 +72,49 @@ ;;; ;;; Code: +(define %metacpan-base-url + ;; Base URL of the MetaCPAN API. + (make-parameter "https://fastapi.metacpan.org/v1/")) + +;; Dependency of a "release". +(define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency? + json->cpan-dependency + (relationship cpan-dependency-relationship "relationship" + string->symbol) ;requires | suggests + (phase cpan-dependency-phase "phase" + string->symbol) ;develop | configure | test | runtime + (module cpan-dependency-module) ;string + (version cpan-dependency-version)) ;string + +;; Release as returned by <https://fastapi.metacpan.org/v1/release/PKG>. +(define-json-mapping <cpan-release> make-cpan-release cpan-release? + json->cpan-release + (license cpan-release-license) + (author cpan-release-author) + (version cpan-release-version "version" + (match-lambda + ((? number? version) + ;; Version is sometimes not quoted in the module json, so + ;; it gets imported into Guile as a number, so convert it + ;; to a string (example: "X11-Protocol-Other"). + (number->string version)) + ((? string? version) + ;; Sometimes we get a "v" prefix. Strip it. + (if (string-prefix? "v" version) + (string-drop version 1) + version)))) + (module cpan-release-module "main_module") ;e.g., "Test::Script" + (distribution cpan-release-distribution) ;e.g., "Test-Script" + (download-url cpan-release-download-url "download_url") + (abstract cpan-release-abstract "abstract") + (home-page cpan-release-home-page "resources" + (match-lambda + (#f #f) + ((lst ...) (assoc-ref lst "homepage")))) + (dependencies cpan-release-dependencies "dependency" + (lambda (vector) + (map json->cpan-dependency (vector->list vector))))) + (define string->license (match-lambda ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec. @@ -89,7 +155,7 @@ module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would return \"Test-Simple\"" (assoc-ref (json-fetch (string-append - "https://fastapi.metacpan.org/v1/module/" + (%metacpan-base-url) "/module/" module "?fields=distribution")) "distribution")) @@ -111,32 +177,25 @@ return \"Test-Simple\"" (_ #f))))) (define (cpan-fetch name) - "Return an alist representation of the CPAN metadata for the perl module MODULE, -or #f on failure. MODULE should be e.g. \"Test::Script\"" + "Return a <cpan-release> record for Perl module MODULE, +or #f on failure. MODULE should be the distribution name, such as +\"Test-Script\" for the \"Test::Script\" module." ;; This API always returns the latest release of the module. - (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name))) + (json->cpan-release + (json-fetch (string-append (%metacpan-base-url) "/release/" + name)))) (define (cpan-home name) (string-append "https://metacpan.org/release/" name)) -(define (cpan-source-url meta) - "Return the download URL for a module's source tarball." +(define (metacpan-url->mirror-url url) + "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'." (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" - (assoc-ref meta "download_url") + url 'pre "mirror://cpan" 'post)) -(define (cpan-version meta) - "Return the version number from META." - (match (assoc-ref meta "version") - ((? number? version) - ;; version is sometimes not quoted in the module json, so it gets - ;; imported into Guile as a number, so convert it to a string. - (number->string version)) - (version - ;; Sometimes we get a "v" prefix. Strip it. - (if (string-prefix? "v" version) - (string-drop version 1) - version)))) +(define cpan-source-url + (compose metacpan-url->mirror-url cpan-release-download-url)) (define (perl-package) "Return the 'perl' package. This is a lazy reference so that we don't @@ -179,42 +238,38 @@ depend on (gnu packages perl)." first perl-version last)))) (loop))))))))))) -(define (cpan-module->sexp meta) - "Return the `package' s-expression for a CPAN module from the metadata in -META." +(define (cpan-module->sexp release) + "Return the 'package' s-expression for a CPAN module from the release data +in RELEASE, a <cpan-release> record." (define name - (assoc-ref meta "distribution")) + (cpan-release-distribution release)) (define (guix-name name) (if (string-prefix? "perl-" name) (string-downcase name) (string-append "perl-" (string-downcase name)))) - (define version (cpan-version meta)) - (define source-url (cpan-source-url meta)) + (define version (cpan-release-version release)) + (define source-url (cpan-source-url release)) (define (convert-inputs phases) ;; Convert phase dependencies into a list of name/variable pairs. - (match (flatten - (map (lambda (ph) - (filter-map (lambda (t) - (assoc-ref* meta "metadata" "prereqs" ph t)) - '("requires" "recommends" "suggests"))) - phases)) - (#f - '()) + (match (filter-map (lambda (dependency) + (and (memq (cpan-dependency-phase dependency) + phases) + (cpan-dependency-module dependency))) + (cpan-release-dependencies release)) ((inputs ...) (sort (delete-duplicates ;; Listed dependencies may include core modules. Filter those out. (filter-map (match-lambda - (("perl" . _) ;implicit dependency - #f) - ((module . _) - (and (not (core-module? module)) - (let ((name (guix-name (module->dist-name module)))) - (list name - (list 'unquote (string->symbol name))))))) + ("perl" #f) ;implicit dependency + ((? core-module?) #f) + (module + (let ((name (guix-name (module->dist-name module)))) + (list name + (list 'unquote (string->symbol name)))))) inputs)) (lambda args (match args @@ -247,19 +302,19 @@ META." ;; which says they are required during building. We ;; have not yet had a need for cross-compiled perl ;; modules, however, so we leave it out. - (convert-inputs '("configure" "build" "test"))) + (convert-inputs '(configure build test))) ,@(maybe-inputs 'propagated-inputs - (convert-inputs '("runtime"))) + (convert-inputs '(runtime))) (home-page ,(cpan-home name)) - (synopsis ,(assoc-ref meta "abstract")) + (synopsis ,(cpan-release-abstract release)) (description fill-in-yourself!) - (license ,(string->license (assoc-ref meta "license")))))) + (license ,(string->license (cpan-release-license release)))))) (define (cpan->guix-package module-name) "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((module-meta (cpan-fetch (module->name module-name)))) - (and=> module-meta cpan-module->sexp))) + (let ((release (cpan-fetch (module->name module-name)))) + (and=> release cpan-module->sexp))) (define (cpan-package? package) "Return #t if PACKAGE is a package from CPAN." @@ -285,7 +340,7 @@ META." "Return an <upstream-source> for the latest release of PACKAGE." (match (cpan-fetch (package->upstream-name package)) (#f #f) - (meta + (release (let ((core-inputs (match (package-direct-inputs package) (((_ inputs _ ...) ...) @@ -303,8 +358,8 @@ META." (warning (G_ "input '~a' of ~a is in Perl core~%") module (package-name package))) core-inputs))) - (let ((version (cpan-version meta)) - (url (cpan-source-url meta))) + (let ((version (cpan-release-version release)) + (url (cpan-source-url release))) (upstream-source (package (package-name package)) (version version) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 13771ec598..bcb37ed250 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -54,7 +54,10 @@ cran-package? bioconductor-package? bioconductor-data-package? - bioconductor-experiment-package?)) + bioconductor-experiment-package? + + description->alist + description->package)) ;;; Commentary: ;;; @@ -270,6 +273,10 @@ empty list when the FIELD cannot be found." (string-any char-set:whitespace item))) (map string-trim-both items)))))) +;; Trick Guile 3 so that it keeps the 'listify' binding accessible *and* +;; private even though this module is declarative. +(set! listify listify) + (define default-r-packages (list "base" "compiler" diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 405a26a877..57823c3639 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. @@ -40,6 +40,7 @@ #:use-module (srfi srfi-26) #:export (crate->guix-package guix-package->crate-name + string->license crate-recursive-import %crate-updater)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 83354d3f04..2d4487dba0 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -72,6 +72,7 @@ NAMES (strings)." "Retrieve the URL of REPO." (let ((elpa-archives '((gnu . "https://elpa.gnu.org/packages") + (gnu/http . "http://elpa.gnu.org/packages") ;for testing (melpa-stable . "https://stable.melpa.org/packages") (melpa . "https://melpa.org/packages")))) (assq-ref elpa-archives repo))) @@ -251,7 +252,7 @@ type '<elpa-package>'." (package ;; ELPA is known to contain only GPLv3+ code. Other repos may contain ;; code under other license but there's no license metadata. - (let ((license (and (eq? 'gnu repo) 'license:gpl3+))) + (let ((license (and (memq repo '(gnu gnu/http)) 'license:gpl3+))) (elpa-package->sexp package license))))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index e258c4197f..394415fdd4 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -1,3 +1,4 @@ +;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. @@ -38,7 +39,14 @@ #:use-module ((guix licenses) #:prefix license:) #:export (opam->guix-package opam-recursive-import - %opam-updater)) + %opam-updater + + ;; The following patterns are exported for testing purposes. + string-pat + multiline-string + list-pat + dict + condition)) ;; Define a PEG parser for the opam format (define-peg-pattern comment none (and "#" (* STRCHR) "\n")) @@ -233,8 +241,8 @@ path to the repository." (list dependency (list 'unquote (string->symbol dependency)))) (ocaml-names->guix-names lst))) -(define (opam-fetch name) - (and-let* ((repository (get-opam-repository)) +(define* (opam-fetch name #:optional (repository (get-opam-repository))) + (and-let* ((repository repository) (version (find-latest-version name repository)) (file (string-append repository "/packages/" name "/" name "." version "/opam"))) `(("metadata" ,@(get-metadata file)) @@ -242,8 +250,11 @@ path to the repository." (substring version 1) version))))) -(define (opam->guix-package name) - (and-let* ((opam-file (opam-fetch name)) +(define* (opam->guix-package name #:key repository) + "Import OPAM package NAME from REPOSITORY (a directory name) or, if +REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp +or #f on failure." + (and-let* ((opam-file (opam-fetch name repository)) (version (assoc-ref opam-file "version")) (opam-content (assoc-ref opam-file "metadata")) (url-dict (metadata-ref opam-content "url")) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index d528aace9a..a84683ef6f 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -38,7 +38,10 @@ #:use-module (guix packages) #:use-module (gnu packages) #:use-module (guix build-system texlive) - #:export (texlive->guix-package)) + #:export (texlive->guix-package + + fetch-sxml + sxml->package)) ;;; Commentary: ;;; diff --git a/guix/inferior.scm b/guix/inferior.scm index c4969cd56a..0236fb61ad 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,7 +44,8 @@ #:use-module (guix derivations) #:use-module (guix base32) #:use-module (gcrypt hash) - #:autoload (guix cache) (maybe-remove-expired-cache-entries) + #:autoload (guix cache) (maybe-remove-expired-cache-entries + file-expiration-time) #:autoload (guix ui) (show-what-to-build*) #:autoload (guix build utils) (mkdir-p) #:use-module (srfi srfi-1) diff --git a/guix/lint.scm b/guix/lint.scm index d2f24c61f8..24fbf05202 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -905,16 +905,31 @@ descriptions maintained upstream." (origin-uris origin)) '()))) +(cond-expand + (guile-3 + ;; Guile 3.0.0 does not export this predicate. + (define exception-with-kind-and-args? + (exception-predicate &exception-with-kind-and-args))) + (else ;Guile 2 + (define exception-with-kind-and-args? + (const #f)))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try system) - (catch #t + (catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported. (lambda () (guard (c ((store-protocol-error? c) (make-warning package (G_ "failed to create ~a derivation: ~a") (list system (store-protocol-error-message c)))) + ((exception-with-kind-and-args? c) + (make-warning package + (G_ "failed to create ~a derivation: ~s") + (list system + (cons (exception-kind c) + (exception-args c))))) ((message-condition? c) (make-warning package (G_ "failed to create ~a derivation: ~a") @@ -1014,8 +1029,11 @@ the NIST server non-fatal." (package-version package)))) ((force lookup) name version))))) -(define (check-vulnerabilities package) - "Check for known vulnerabilities for PACKAGE." +(define* (check-vulnerabilities package + #:optional (package-vulnerabilities + package-vulnerabilities)) + "Check for known vulnerabilities for PACKAGE. Obtain the list of +vulnerability records for PACKAGE by calling PACKAGE-VULNERABILITIES." (let ((package (or (package-replacement package) package))) (match (package-vulnerabilities package) (() diff --git a/guix/lzlib.scm b/guix/lzlib.scm index 24c7b4b448..2fc326ba34 100644 --- a/guix/lzlib.scm +++ b/guix/lzlib.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +32,8 @@ call-with-lzip-input-port call-with-lzip-output-port %default-member-length-limit - %default-compression-level)) + %default-compression-level + dictionary-size+match-length-limit)) ;;; Commentary: ;;; @@ -569,20 +570,27 @@ the number of uncompressed bytes written, a non-negative integer." ;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest. ;; See bbexample.c in lzlib's source. (define %compression-levels - `((0 (65535 16)) - (1 (,(bitwise-arithmetic-shift-left 1 20) 5)) - (2 (,(bitwise-arithmetic-shift-left 3 19) 6)) - (3 (,(bitwise-arithmetic-shift-left 1 21) 8)) - (4 (,(bitwise-arithmetic-shift-left 3 20) 12)) - (5 (,(bitwise-arithmetic-shift-left 1 22) 20)) - (6 (,(bitwise-arithmetic-shift-left 1 23) 36)) - (7 (,(bitwise-arithmetic-shift-left 1 24) 68)) - (8 (,(bitwise-arithmetic-shift-left 3 23) 132)) - (9 (,(bitwise-arithmetic-shift-left 1 25) 273)))) + `((0 65535 16) + (1 ,(bitwise-arithmetic-shift-left 1 20) 5) + (2 ,(bitwise-arithmetic-shift-left 3 19) 6) + (3 ,(bitwise-arithmetic-shift-left 1 21) 8) + (4 ,(bitwise-arithmetic-shift-left 3 20) 12) + (5 ,(bitwise-arithmetic-shift-left 1 22) 20) + (6 ,(bitwise-arithmetic-shift-left 1 23) 36) + (7 ,(bitwise-arithmetic-shift-left 1 24) 68) + (8 ,(bitwise-arithmetic-shift-left 3 23) 132) + (9 ,(bitwise-arithmetic-shift-left 1 25) 273))) (define %default-compression-level 6) +(define (dictionary-size+match-length-limit level) + "Return two values: the dictionary size for LEVEL, and its match-length +limit. LEVEL must be a compression level, an integer between 0 and 9." + (match (assv-ref %compression-levels level) + ((dictionary-size match-length-limit) + (values dictionary-size match-length-limit)))) + (define* (make-lzip-input-port port) "Return an input port that decompresses data read from PORT, a file port. PORT is automatically closed when the resulting port is closed." @@ -602,8 +610,9 @@ PORT is automatically closed when the resulting port is closed." "Return an output port that compresses data at the given LEVEL, using PORT, a file port, as its sink. PORT is automatically closed when the resulting port is closed." - (define encoder (apply lz-compress-open - (car (assoc-ref %compression-levels level)))) + (define encoder + (call-with-values (lambda () (dictionary-size+match-length-limit level)) + lz-compress-open)) (define (write! bv start count) (lzwrite encoder bv port start count)) @@ -626,8 +635,9 @@ port is closed." (level %default-compression-level)) "Return an input port that compresses data read from PORT, with the given LEVEL. PORT is automatically closed when the resulting port is closed." - (define encoder (apply lz-compress-open - (car (assoc-ref %compression-levels level)))) + (define encoder + (call-with-values (lambda () (dictionary-size+match-length-limit level)) + lz-compress-open)) (define input-buffer (make-bytevector 8192)) (define input-len 0) diff --git a/guix/records.scm b/guix/records.scm index 99507dc384..4bda5426a3 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -70,14 +70,22 @@ interface\" (ABI) for TYPE is equal to COOKIE." "~a: record ABI mismatch; recompilation needed" (list #,type) '())))) - (define (report-invalid-field-specifier name bindings) - "Report the first invalid binding among BINDINGS." + (define* (report-invalid-field-specifier name bindings + #:optional parent-form) + "Report the first invalid binding among BINDINGS. PARENT-FORM is used for +error-reporting purposes." (let loop ((bindings bindings)) (syntax-case bindings () (((field value) rest ...) ;good (loop #'(rest ...))) ((weird _ ...) ;weird! - (syntax-violation name "invalid field specifier" #'weird))))) + ;; WEIRD may be an identifier, thus lacking source location info, and + ;; BINDINGS is a list, also lacking source location info. Hopefully + ;; PARENT-FORM provides source location info. + (apply syntax-violation name "invalid field specifier" + (if parent-form + (list parent-form #'weird) + (list #'weird))))))) (define (report-duplicate-field-specifier name ctor) "Report the first duplicate identifier among the bindings in CTOR." @@ -233,7 +241,8 @@ of TYPE matches the expansion-time ABI." ;; Report precisely which one is faulty, instead of letting the ;; "source expression failed to match any pattern" error. (report-invalid-field-specifier 'name - #'(bindings (... ...)))))))))) + #'(bindings (... ...)) + s)))))))) (define-syntax-rule (define-field-property-predicate predicate property) "Define PREDICATE as a procedure that takes a syntax object and, when passed diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index ebeebd5cbe..65e2427033 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,7 @@ #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) - #:use-module (guix progress) + #:use-module ((guix progress) #:hide (dump-port*)) #:use-module (guix serialization) #:use-module (guix scripts substitute) #:use-module (rnrs bytevectors) @@ -193,9 +193,6 @@ taken since we do not import the archives." ;;; 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))) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index da3d2775e8..a6fd1d2751 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> +;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +21,7 @@ (define-module (guix scripts edit) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module ((guix scripts build) #:select (%standard-build-options)) #:use-module (guix utils) #:use-module (gnu packages) #:use-module (srfi srfi-1) @@ -28,7 +30,10 @@ guix-edit)) (define %options - (list (option '(#\h "help") #f #f + (list (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options) + (option '(#\h "help") #f #f (lambda args (show-help) (exit 0))) @@ -41,6 +46,9 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (newline) (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 7558cb1e85..53f407b2fc 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,7 @@ #:use-module ((guix scripts build) #:select (show-transformation-options-help options->transformation + %standard-build-options %transformation-options)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -473,6 +475,9 @@ package modules, while attempting to retain user package modules." (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options) (option '(#\h "help") #f #f (lambda args (show-help) @@ -501,6 +506,9 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\"")) (newline) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) (show-transformation-options-help) (newline) (display (G_ " diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ea16435d2d..1cb0d382bf 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -39,7 +39,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix describe) - #:autoload (guix store roots) (gc-roots) + #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix build syscalls) @@ -63,6 +63,8 @@ delete-matching-generations guix-package + transaction-upgrade-entry ;mostly for testing + (%options . %package-options) (%default-options . %package-default-options) guix-package*)) @@ -135,9 +137,6 @@ denote ranges as interpreted by 'matching-generations'." specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile hooks\" run when building the profile." - (when (equal? profile %current-profile) - (ensure-default-profile)) - (let* ((prof-drv (run-with-store store (profile-derivation manifest #:allow-collisions? allow-collisions? @@ -205,7 +204,7 @@ non-zero relevance score." (package-full-name package2)) (> score1 score2)))))))))) -(define (transaction-upgrade-entry entry transaction) +(define (transaction-upgrade-entry store entry transaction) "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a <manifest-entry>." (define (supersede old new) @@ -242,7 +241,7 @@ non-zero relevance score." transaction) ((=) (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) + (package-derivation store pkg)))) ;; XXX: When there are propagated inputs, assume we need to ;; upgrade the whole entry. (if (and (string=? path candidate-path) @@ -600,7 +599,7 @@ and upgrades." (define upgraded (fold (lambda (entry transaction) (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) + (transaction-upgrade-entry (%store) entry transaction) transaction)) transaction (manifest-entries manifest))) @@ -863,6 +862,12 @@ processed, #f otherwise." (package-version item) (manifest-entry-version entry)))))) + (when (equal? profile %current-profile) + ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless + ;; it's a version that lacks the fix for <https://bugs.gnu.org/37744> + ;; (aka. CVE-2019-18192). Ensure %CURRENT-PROFILE exists so that + ;; 'with-profile-lock' can create its lock file below. + (ensure-default-profile)) ;; First, acquire a lock on the profile, to ensure only one guix process ;; is modifying it at a time. diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 71a349d2fe..f5b2f5fd4e 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -64,6 +64,7 @@ #:use-module ((guix build syscalls) #:select (set-thread-name)) #:export (%public-key %private-key + signed-string guix-publish)) @@ -237,7 +238,8 @@ if ITEM is already compressed." ("Priority" . 100))) (define (signed-string s) - "Sign the hash of the string S with the daemon's key." + "Sign the hash of the string S with the daemon's key. Return a canonical +sexp for the signature." (let* ((public-key (%public-key)) (hash (bytevector->hash-data (sha256 (string->utf8 s)) #:key-type (key-type public-key)))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index daf6fcf947..efada1df5a 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ #:use-module (guix ui) #:use-module (gcrypt hash) #:use-module (guix scripts) + #:use-module ((guix scripts build) #:select (%standard-build-options)) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) @@ -116,6 +118,19 @@ (leave (G_ "unsupported policy: ~a~%") arg))))) + ;; The short option -L is already used by --list-updaters, therefore + ;; it needs to be removed from %standard-build-options. + (let ((load-path-option (find (lambda (option) + (member "load-path" + (option-names option))) + %standard-build-options))) + (option + (filter (lambda (name) (not (equal? #\L name))) + (option-names load-path-option)) + (option-required-arg? load-path-option) + (option-optional-arg? load-path-option) + (option-processor load-path-option))) + (option '(#\h "help") #f #f (lambda args (show-help) @@ -166,6 +181,9 @@ specified with `--select'.\n")) used when 'key-download' is not specified")) (newline) (display (G_ " + --load-path=DIR prepend DIR to the package module search path")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index e1cc759fc8..ff1f208894 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,9 +21,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix repl) - #:use-module (guix utils) - #:use-module (guix packages) - #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) #:use-module (ice-9 match) @@ -52,7 +50,16 @@ (alist-cons 'type (string->symbol arg) result))) (option '("listen") #t #f (lambda (opt name arg result) - (alist-cons 'listen arg result))))) + (alist-cons 'listen arg result))) + (option '(#\q) #f #f + (lambda (opt name arg result) + (alist-cons 'ignore-dot-guile? #t result))) + (option '(#\L "load-path") #t #f + (lambda (opt name arg result) + ;; XXX: Imperatively modify the search paths. + (set! %load-path (cons arg %load-path)) + (set! %load-compiled-path (cons arg %load-compiled-path)) + result)))) (define (show-help) @@ -60,6 +67,13 @@ Start a Guile REPL in the Guix execution environment.\n")) (display (G_ " -t, --type=TYPE start a REPL of the given TYPE")) + (display (G_ " + --listen=ENDPOINT listen to ENDPOINT instead of standard input")) + (display (G_ " + -q inhibit loading of ~/.guile")) + (newline) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -129,6 +143,11 @@ call THUNK." (leave (G_ "~A: extraneous argument~%") arg)) %default-options)) + (define user-config + (and=> (getenv "HOME") + (lambda (home) + (string-append home "/.guile")))) + (with-error-handling (let ((type (assoc-ref opts 'type))) (call-with-connection (assoc-ref opts 'listen) @@ -138,11 +157,11 @@ call THUNK." (save-module-excursion (lambda () (set-current-module user-module) - (and=> (getenv "HOME") - (lambda (home) - (let ((guile (string-append home "/.guile"))) - (when (file-exists? guile) - (load guile))))) + (when (and (not (assoc-ref opts 'ignore-dot-guile?)) + user-config + (file-exists? user-config)) + (load user-config)) + ;; Do not exit repl on SIGINT. ((@@ (ice-9 top-repl) call-with-sigint) (lambda () diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index f549ce05b8..2446b84587 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +20,7 @@ (define-module (guix scripts size) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix scripts build) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix combinators) @@ -242,6 +244,9 @@ Report the size of PACKAGE and its dependencies.\n")) -m, --map-file=FILE write to FILE a graphical map of disk usage")) (newline) (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -273,6 +278,9 @@ Report the size of PACKAGE and its dependencies.\n")) (option '(#\m "map-file") #t #f (lambda (opt name arg result) (alist-cons 'map-file arg result))) + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options) (option '(#\h "help") #f #f (lambda args (show-help) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 3bf9b8735f..dfb975a24a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -557,7 +557,7 @@ initial connection on which HTTP requests are sent." (('connection 'close) (close-port p) (connect #f ;try again - (append tail (drop requests processed)) + (drop requests (+ 1 processed)) result)) (_ (loop tail (+ 1 processed) result)))))))))) ;keep going diff --git a/guix/serialization.scm b/guix/serialization.scm index f793feb53d..9452303730 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,6 +36,7 @@ write-string-pairs write-store-path read-store-path write-store-path-list read-store-path-list + (dump . dump-port*) &nar-error nar-error? diff --git a/guix/ui.scm b/guix/ui.scm index 023e604085..4857a88827 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -55,7 +55,9 @@ ;; in 5d669883ecc104403c5d3ba7d172e9c02234577c, #:hide ;; unwanted bindings instead of #:select'ing the needed ;; bindings. - #:hide (package-name->name+version)) + #:hide (package-name->name+version + ;; Avoid "overrides core binding" warning. + delete)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -173,7 +175,11 @@ information, or #f if it could not be found." (previous frame)) (if (not frame) previous - (if (frame-source frame) + + ;; On Guile 3, the latest frame with source may be that of + ;; 'raise-exception' in boot-9.scm. Skip it. + (if (and (frame-source frame) + (not (eq? 'raise-exception (frame-procedure-name frame)))) frame (loop (frame-previous frame) frame))))) @@ -370,9 +376,10 @@ ARGS is the list of arguments received by the 'throw' handler." (format (current-error-port) (G_ "~amissing closing parenthesis~%") location)) (apply throw args))) - (('syntax-error proc message properties form . rest) + (('syntax-error proc message properties form subform . rest) (let ((loc (source-properties->location properties))) - (report-error loc (G_ "~a~%") message))) + (report-error loc (G_ "~s: ~a~%") + (or subform form) message))) (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (((or 'srfi-34 '%exception) obj) |