summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2021-02-03 09:14:43 +0000
committerChristopher Baines <mail@cbaines.net>2021-02-03 09:57:35 +0000
commite740cc614096e768813280c718f9e96343ba41b3 (patch)
tree25ade70a5d408be80f62f19c6511172aab7dcce5 /guix
parent1b9186828867e77af1f2ee6741063424f8256398 (diff)
parent63cf277bfacf282d2b19f00553745b2a9370eca0 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/julia.scm6
-rw-r--r--guix/build/julia-build-system.scm58
-rw-r--r--guix/build/profiles.scm6
-rw-r--r--guix/cache.scm9
-rw-r--r--guix/channels.scm134
-rw-r--r--guix/ci.scm42
-rw-r--r--guix/describe.scm34
-rw-r--r--guix/git.scm44
-rw-r--r--guix/gnu-maintenance.scm5
-rw-r--r--guix/import/cpan.scm3
-rw-r--r--guix/import/cran.scm8
-rw-r--r--guix/import/gem.scm5
-rw-r--r--guix/import/gnu.scm31
-rw-r--r--guix/import/texlive.scm28
-rw-r--r--guix/inferior.scm105
-rw-r--r--guix/licenses.scm17
-rw-r--r--guix/modules.scm4
-rw-r--r--guix/narinfo.scm327
-rw-r--r--guix/profiles.scm86
-rw-r--r--guix/repl.scm8
-rw-r--r--guix/scripts/archive.scm4
-rw-r--r--guix/scripts/challenge.scm1
-rw-r--r--guix/scripts/describe.scm52
-rw-r--r--guix/scripts/environment.scm2
-rw-r--r--guix/scripts/import/json.scm10
-rw-r--r--guix/scripts/package.scm118
-rw-r--r--guix/scripts/publish.scm31
-rw-r--r--guix/scripts/pull.scm103
-rwxr-xr-xguix/scripts/substitute.scm298
-rw-r--r--guix/scripts/system.scm26
-rw-r--r--guix/scripts/system/reconfigure.scm9
-rw-r--r--guix/scripts/weather.scm1
-rw-r--r--guix/self.scm6
-rw-r--r--guix/serialization.scm16
-rw-r--r--guix/store.scm17
-rw-r--r--guix/store/database.scm45
-rw-r--r--guix/swh.scm3
-rw-r--r--guix/transformations.scm49
-rw-r--r--guix/ui.scm32
-rw-r--r--guix/upstream.scm28
-rw-r--r--guix/utils.scm48
41 files changed, 1245 insertions, 614 deletions
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm
index 488fe9bb1d..63cb7cd864 100644
--- a/guix/build-system/julia.scm
+++ b/guix/build-system/julia.scm
@@ -75,13 +75,14 @@
(define* (julia-build store name inputs
#:key source
- (tests? #f)
+ (tests? #t)
(phases '(@ (guix build julia-build-system)
%standard-phases))
(outputs '("out"))
(search-paths '())
(system (%current-system))
(guile #f)
+ (julia-package-name #f)
(imported-modules %julia-build-system-modules)
(modules '((guix build julia-build-system)
(guix build utils))))
@@ -103,7 +104,8 @@
#:outputs %outputs
#:search-paths ',(map search-path-specification->sexp
search-paths)
- #:inputs %build-inputs)))
+ #:inputs %build-inputs
+ #:julia-package-name ,julia-package-name)))
(define guile-for-build
(match guile
diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm
index e8ebcf8ba0..8f57045a8c 100644
--- a/guix/build/julia-build-system.scm
+++ b/guix/build/julia-build-system.scm
@@ -21,6 +21,8 @@
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
#:use-module (guix build utils)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
#:export (%standard-phases
julia-create-package-toml
julia-build))
@@ -37,18 +39,34 @@
;; subpath where we store the package content
(define %package-path "/share/julia/packages/")
-(define* (install #:key source inputs outputs #:allow-other-keys)
+(define (project.toml->name file)
+ "Look for Julia package name in the TOML file FILE (usually named
+Project.toml)."
+ (call-with-input-file file
+ (lambda (in)
+ (let loop ((line (read-line in 'concat)))
+ (if (eof-object? line)
+ #f
+ (let ((m (string-match "name\\s*=\\s*\"(.*)\"" line)))
+ (if m (match:substring m 1)
+ (loop (read-line in 'concat)))))))))
+
+(define* (install #:key source inputs outputs julia-package-name
+ #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(package-dir (string-append out %package-path
- (strip-store-file-name source))))
+ (or
+ julia-package-name
+ (project.toml->name "Project.toml")))))
(mkdir-p package-dir)
(copy-recursively (getcwd) package-dir))
#t)
-(define* (precompile #:key source inputs outputs #:allow-other-keys)
+(define* (precompile #:key source inputs outputs julia-package-name
+ #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(builddir (string-append out "/share/julia/"))
- (package (strip-store-file-name source)))
+ (package (or julia-package-name (project.toml->name "Project.toml"))))
(mkdir-p builddir)
;; With a patch, SOURCE_DATE_EPOCH is honored
(setenv "SOURCE_DATE_EPOCH" "1")
@@ -69,15 +87,23 @@
(string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package)))
#t)
-(define* (check #:key source inputs outputs #:allow-other-keys)
- (let* ((out (assoc-ref outputs "out"))
- (package (strip-store-file-name source))
- (builddir (string-append out "/share/julia/")))
- ;; With a patch, SOURCE_DATE_EPOCH is honored
- (setenv "SOURCE_DATE_EPOCH" "1")
- (setenv "JULIA_DEPOT_PATH" builddir)
- (setenv "JULIA_LOAD_PATH" (string-append builddir "packages/"))
- (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")")))
+(define* (check #:key tests? source inputs outputs julia-package-name
+ #:allow-other-keys)
+ (when tests?
+ (let* ((out (assoc-ref outputs "out"))
+ (package (or julia-package-name (project.toml->name "Project.toml")))
+ (builddir (string-append out "/share/julia/")))
+ ;; With a patch, SOURCE_DATE_EPOCH is honored
+ (setenv "SOURCE_DATE_EPOCH" "1")
+ (setenv "JULIA_DEPOT_PATH" builddir)
+ (setenv "JULIA_LOAD_PATH"
+ (string-append builddir "packages/" ":"
+ (or (getenv "JULIA_LOAD_PATH")
+ "")))
+ (setenv "HOME" "/tmp")
+ (invoke "julia"
+ (string-append builddir "packages/"
+ package "/test/runtests.jl"))))
#t)
(define (julia-create-package-toml outputs source
@@ -112,7 +138,7 @@ version = \"" version "\"
(delete 'check) ; tests must be run after installation
(replace 'install install)
(add-after 'install 'precompile precompile)
- ;; (add-after 'install 'check check)
+ (add-after 'install 'check check)
;; TODO: In the future we could add a "system-image-generation" phase
;; where we use PackageCompiler.jl to speed up package loading times
(delete 'configure)
@@ -120,9 +146,11 @@ version = \"" version "\"
(delete 'patch-usr-bin-file)
(delete 'build)))
-(define* (julia-build #:key inputs (phases %standard-phases)
+(define* (julia-build #:key inputs julia-package-name
+ (phases %standard-phases)
#:allow-other-keys #:rest args)
"Build the given Julia package, applying all of PHASES in order."
(apply gnu:gnu-build
#:inputs inputs #:phases phases
+ #:julia-package-name julia-package-name
args))
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index 67ee9b665a..b42f498a80 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -169,7 +169,9 @@ SEARCH-PATHS."
(lambda (p)
(display "\
;; This file was automatically generated and is for internal use only.
-;; It cannot be passed to the '--manifest' option.\n\n"
+;; It cannot be passed to the '--manifest' option.
+;; Run 'guix package --export-manifest' if to export a file suitable
+;; for '--manifest'.\n\n"
p)
(pretty-print manifest p)))
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/channels.scm b/guix/channels.scm
index 0c84eed477..e7e1eb6fd0 100644
--- a/guix/channels.scm
+++ b/guix/channels.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 © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
@@ -91,6 +91,9 @@
ensure-forward-channel-update
profile-channels
+ manifest-entry-channel
+ sexp->channel
+ channel->code
channel-news-entry?
channel-news-entry-commit
@@ -802,13 +805,36 @@ derivation."
(derivation-input-derivation input))))
(derivation-inputs drv))))
+(define (channel-instance->sexp instance)
+ "Return an sexp representation of INSTANCE, a channel instance."
+ (let* ((commit (channel-instance-commit instance))
+ (channel (channel-instance-channel instance))
+ (intro (channel-introduction channel)))
+ `(repository
+ (version 0)
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,commit)
+ (name ,(channel-name channel))
+ ,@(if intro
+ `((introduction
+ (channel-introduction
+ (version 0)
+ (commit
+ ,(channel-introduction-first-signed-commit
+ intro))
+ (signer
+ ,(openpgp-format-fingerprint
+ (channel-introduction-first-commit-signer
+ intro))))))
+ '()))))
+
(define (channel-instances->manifest instances)
"Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
(define (instance->entry instance drv)
- (let* ((commit (channel-instance-commit instance))
- (channel (channel-instance-channel instance))
- (intro (channel-introduction channel)))
+ (let ((commit (channel-instance-commit instance))
+ (channel (channel-instance-channel instance)))
(manifest-entry
(name (symbol->string (channel-name channel)))
(version (string-take commit 7))
@@ -819,23 +845,7 @@ channel instances."
drv)
drv))
(properties
- `((source (repository
- (version 0)
- (url ,(channel-url channel))
- (branch ,(channel-branch channel))
- (commit ,commit)
- ,@(if intro
- `((introduction
- (channel-introduction
- (version 0)
- (commit
- ,(channel-introduction-first-signed-commit
- intro))
- (signer
- ,(openpgp-format-fingerprint
- (channel-introduction-first-commit-signer
- intro))))))
- '()))))))))
+ `((source ,(channel-instance->sexp instance)))))))
(mlet* %store-monad ((derivations (channel-instance-derivations instances))
(entries -> (map instance->entry instances derivations)))
@@ -900,35 +910,73 @@ to 'latest-channel-instances'."
validate-pull)))
(channel-instances->derivation instances)))
+(define* (sexp->channel sexp #:optional (name 'channel))
+ "Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use
+NAME as the channel name if SEXP does not specify it. Return #f if the sexp
+does not have the expected structure."
+ (match sexp
+ (('repository ('version 0)
+ ('url url)
+ ('branch branch)
+ ('commit commit)
+ rest ...)
+ ;; Historically channel sexps did not include the channel name. It's OK
+ ;; for channels created by 'channel-instances->manifest' because the
+ ;; entry name is the channel name, but it was missing for entries created
+ ;; by 'manifest-entry-with-provenance'.
+ (channel (name (match (assq 'name rest)
+ (#f name)
+ (('name name) name)))
+ (url url)
+ (commit commit)
+ (introduction
+ (match (assq 'introduction rest)
+ (#f #f)
+ (('introduction intro)
+ (sexp->channel-introduction intro))))))
+
+ (_ #f)))
+
+(define (manifest-entry-channel entry)
+ "Return the channel ENTRY corresponds to, or #f if that information is
+missing or unreadable. ENTRY must be an entry created by
+'channel-instances->manifest', with the 'source' property."
+ (let ((name (string->symbol (manifest-entry-name entry))))
+ (match (assq-ref (manifest-entry-properties entry) 'source)
+ ((sexp)
+ (sexp->channel sexp name))
+ (_
+ ;; No channel information for this manifest entry.
+ ;; XXX: Pre-0.15.0 Guix did not provide that information,
+ ;; but there's not much we can do in that case.
+ #f))))
+
(define (profile-channels profile)
"Return the list of channels corresponding to entries in PROFILE. If
PROFILE is not a profile created by 'guix pull', return the empty list."
- (filter-map (lambda (entry)
- (match (assq 'source (manifest-entry-properties entry))
- (('source ('repository ('version 0)
- ('url url)
- ('branch branch)
- ('commit commit)
- rest ...))
- (channel (name (string->symbol
- (manifest-entry-name entry)))
- (url url)
- (commit commit)
- (introduction
- (match (assq 'introduction rest)
- (#f #f)
- (('introduction intro)
- (sexp->channel-introduction intro))))))
-
- ;; No channel information for this manifest entry.
- ;; XXX: Pre-0.15.0 Guix did not provide that information,
- ;; but there's not much we can do in that case.
- (_ #f)))
-
+ (filter-map manifest-entry-channel
;; Show most recently installed packages last.
(reverse
(manifest-entries (profile-manifest profile)))))
+(define* (channel->code channel #:key (include-introduction? #t))
+ "Return code (an sexp) to build CHANNEL. When INCLUDE-INTRODUCTION? is
+true, include its introduction, if any."
+ (let ((intro (and include-introduction?
+ (channel-introduction channel))))
+ `(channel
+ (name ',(channel-name channel))
+ (url ,(channel-url channel))
+ (commit ,(channel-commit channel))
+ ,@(if intro
+ `((introduction (make-channel-introduction
+ ,(channel-introduction-first-signed-commit intro)
+ (openpgp-fingerprint
+ ,(openpgp-format-fingerprint
+ (channel-introduction-first-commit-signer
+ intro))))))
+ '()))))
+
;;;
;;; News.
diff --git a/guix/ci.scm b/guix/ci.scm
index f429bf198f..f04109112c 100644
--- a/guix/ci.scm
+++ b/guix/ci.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 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -19,9 +19,13 @@
(define-module (guix ci)
#:use-module (guix http-client)
+ #:use-module (guix utils)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
+ #:use-module (guix i18n)
+ #:use-module (guix diagnostics)
+ #:autoload (guix channels) (channel)
#:export (build-product?
build-product-id
build-product-type
@@ -52,7 +56,9 @@
latest-builds
evaluation
latest-evaluations
- evaluations-for-commit))
+ evaluations-for-commit
+
+ channel-with-substitutes-available))
;;; Commentary:
;;;
@@ -165,3 +171,35 @@ as one of their inputs."
(string=? (checkout-commit checkout) commit))
(evaluation-checkouts evaluation)))
(latest-evaluations url limit)))
+
+(define (find-latest-commit-with-substitutes url)
+ "Return the latest commit with available substitutes for the Guix package
+definitions at URL. Return false if no commit were found."
+ (let* ((job-name (string-append "guix." (%current-system)))
+ (build (match (latest-builds url 1
+ #:job job-name
+ #:status 0) ;success
+ ((build) build)
+ (_ #f)))
+ (evaluation (and build
+ (evaluation url (build-evaluation build))))
+ (commit (and evaluation
+ (match (evaluation-checkouts evaluation)
+ ((checkout)
+ (checkout-commit checkout))))))
+ commit))
+
+(define (channel-with-substitutes-available chan url)
+ "Return a channel inheriting from CHAN but which commit field is set to the
+latest commit with available substitutes for the Guix package definitions at
+URL. The current system is taken into account.
+
+If no commit with available substitutes were found, the commit field is set to
+false and a warning message is printed."
+ (let ((commit (find-latest-commit-with-substitutes url)))
+ (unless commit
+ (warning (G_ "could not find available substitutes at ~a~%")
+ url))
+ (channel
+ (inherit chan)
+ (commit commit))))
diff --git a/guix/describe.scm b/guix/describe.scm
index 05bf99eb58..ac89fc0d7c 100644
--- a/guix/describe.scm
+++ b/guix/describe.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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +23,7 @@
#:use-module ((guix utils) #:select (location-file))
#:use-module ((guix store) #:select (%store-prefix store-path?))
#:use-module ((guix config) #:select (%state-directory))
+ #:autoload (guix channels) (sexp->channel)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (current-profile
@@ -31,7 +32,8 @@
package-path-entries
package-provenance
- manifest-entry-with-provenance))
+ manifest-entry-with-provenance
+ manifest-entry-provenance))
;;; Commentary:
;;;
@@ -166,3 +168,31 @@ there."
(#f properties)
(sexp `((provenance ,@sexp)
,@properties)))))))))
+
+(define (manifest-entry-provenance entry)
+ "Return the list of channels ENTRY comes from. Return the empty list if
+that information is missing."
+ (match (assq-ref (manifest-entry-properties entry) 'provenance)
+ ((main extras ...)
+ ;; XXX: Until recently, channel sexps lacked the channel name. For
+ ;; entries created by 'manifest-entry-with-provenance', the first sexp
+ ;; is known to be the 'guix channel, and for the other ones, invent a
+ ;; fallback name (it's OK as the name is just a "pet name").
+ (match (sexp->channel main 'guix)
+ (#f '())
+ (channel
+ (let loop ((extras extras)
+ (counter 1)
+ (channels (list channel)))
+ (match extras
+ (()
+ (reverse channels))
+ ((head . tail)
+ (let* ((name (string->symbol
+ (format #f "channel~a" counter)))
+ (extra (sexp->channel head name)))
+ (if extra
+ (loop tail (+ 1 counter) (cons extra channels))
+ (loop tail counter channels)))))))))
+ (_
+ '())))
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/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 08b2bcf758..0da6fc19b6 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -361,7 +362,9 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(let loop ((directory directory)
(result #f))
- (let* ((entries (ftp-list conn directory))
+ (let* ((entries (catch 'ftp-error
+ (lambda _ (ftp-list conn directory))
+ (const '())))
;; Filter out things like /gnupg/patches. Filter out "w32"
;; directories as found on ftp.gnutls.org.
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/gnu.scm b/guix/import/gnu.scm
index 29324d7554..51d5b77d34 100644
--- a/guix/import/gnu.scm
+++ b/guix/import/gnu.scm
@@ -1,5 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,8 +19,10 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix import gnu)
+ #:use-module ((guix diagnostics) #:select (formatted-message))
#:use-module (guix gnu-maintenance)
#:use-module (guix import utils)
+ #:use-module (guix i18n)
#:use-module (guix utils)
#:use-module (guix store)
#:use-module (gcrypt hash)
@@ -108,20 +112,17 @@ download policy (see 'download-tarball' for details.)"
"Return the package declaration for NAME as an s-expression. Use
KEY-DOWNLOAD as the OpenPGP key download policy (see 'download-tarball' for
details.)"
- (match (latest-release name)
- ((? upstream-source? release)
- (let ((version (upstream-source-version release)))
- (match (find-package name)
- (#f
- (raise (condition
- (&message
- (message "couldn't find meta-data for GNU package")))))
- (info
- (gnu-package->sexp info release #:key-download key-download)))))
- (_
- (raise (condition
- (&message
- (message
- "failed to determine latest release of GNU package")))))))
+ (let ((package (find-package name)))
+ (unless package
+ (raise (formatted-message (G_ "no GNU package found for ~a") name)))
+
+ (match (latest-release name)
+ ((? upstream-source? release)
+ (let ((version (upstream-source-version release)))
+ (gnu-package->sexp package release #:key-download key-download)))
+ (_
+ (raise (formatted-message
+ (G_ "failed to determine latest release of GNU ~a")
+ name))))))
;;; gnu.scm ends here
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/inferior.scm b/guix/inferior.scm
index 2fe91beaab..0990696e6c 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,6 +40,7 @@
#:use-module (guix search-paths)
#:use-module (guix profiles)
#:use-module (guix channels)
+ #:use-module ((guix git) #:select (update-cached-checkout))
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix derivations)
@@ -51,6 +52,7 @@
#:autoload (guix build utils) (mkdir-p)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:autoload (ice-9 ftw) (scandir)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
@@ -311,8 +313,7 @@ Raise '&inferior-exception' when an exception is read from PORT."
"Return the list of name/version pairs corresponding to the set of packages
available in INFERIOR.
-This is faster and requires less resource-intensive than calling
-'inferior-packages'."
+This is faster and less resource-intensive than calling 'inferior-packages'."
(if (inferior-eval '(defined? 'fold-available-packages)
inferior)
(inferior-eval '(fold-available-packages
@@ -642,29 +643,45 @@ failing when GUIX is too old and lacks the 'guix repl' command."
(define* (inferior-package->manifest-entry package
#:optional (output "out")
- #:key (parent (delay #f))
- (properties '()))
+ #:key (properties '()))
"Return a manifest entry for the OUTPUT of package PACKAGE."
- ;; For each dependency, keep a promise pointing to its "parent" entry.
- (letrec* ((deps (map (match-lambda
- ((label package)
- (inferior-package->manifest-entry package
- #:parent (delay entry)))
- ((label package output)
- (inferior-package->manifest-entry package output
- #:parent (delay entry))))
- (inferior-package-propagated-inputs package)))
- (entry (manifest-entry
- (name (inferior-package-name package))
- (version (inferior-package-version package))
- (output output)
- (item package)
- (dependencies (delete-duplicates deps))
- (search-paths
- (inferior-package-transitive-native-search-paths package))
- (parent parent)
- (properties properties))))
- entry))
+ (define cache
+ (make-hash-table))
+
+ (define-syntax-rule (memoized package output exp)
+ ;; Memoize the entry returned by EXP for PACKAGE/OUTPUT. This is
+ ;; important as the same package may be traversed many times through
+ ;; propagated inputs, and querying the inferior is costly. Use
+ ;; 'hash'/'equal?', which is okay since <inferior-package> is simple.
+ (let ((compute (lambda () exp))
+ (key (cons package output)))
+ (or (hash-ref cache key)
+ (let ((result (compute)))
+ (hash-set! cache key result)
+ result))))
+
+ (let loop ((package package)
+ (output output)
+ (parent (delay #f)))
+ (memoized package output
+ ;; For each dependency, keep a promise pointing to its "parent" entry.
+ (letrec* ((deps (map (match-lambda
+ ((label package)
+ (loop package "out" (delay entry)))
+ ((label package output)
+ (loop package output (delay entry))))
+ (inferior-package-propagated-inputs package)))
+ (entry (manifest-entry
+ (name (inferior-package-name package))
+ (version (inferior-package-version package))
+ (output output)
+ (item package)
+ (dependencies (delete-duplicates deps))
+ (search-paths
+ (inferior-package-transitive-native-search-paths package))
+ (parent parent)
+ (properties properties))))
+ entry))))
;;;
@@ -676,6 +693,21 @@ failing when GUIX is too old and lacks the 'guix repl' command."
(make-parameter (string-append (cache-directory #:ensure? #f)
"/inferiors")))
+(define (channel-full-commit channel)
+ "Return the commit designated by CHANNEL as quickly as possible. If
+CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1
+prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
+ (let ((commit (channel-commit channel))
+ (branch (channel-branch channel)))
+ (if (and commit (= (string-length commit) 40))
+ commit
+ (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch)))
+ (cache commit relation
+ (update-cached-checkout (channel-url channel)
+ #:ref ref
+ #:check-out? #f)))
+ commit))))
+
(define* (cached-channel-instance store
channels
#:key
@@ -686,15 +718,16 @@ failing when GUIX is too old and lacks the 'guix repl' command."
The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
This procedure opens a new connection to the build daemon. AUTHENTICATE?
determines whether CHANNELS are authenticated."
- (define instances
- (latest-channel-instances store channels
- #:authenticate? authenticate?))
+ (define commits
+ ;; Since computing the instances of CHANNELS is I/O-intensive, use a
+ ;; cheaper way to get the commit list of CHANNELS. This limits overhead
+ ;; to the minimum in case of a cache hit.
+ (map channel-full-commit channels))
(define key
(bytevector->base32-string
(sha256
- (string->utf8
- (string-concatenate (map channel-instance-commit instances))))))
+ (string->utf8 (string-concatenate commits)))))
(define cached
(string-append cache-directory "/" key))
@@ -722,8 +755,12 @@ determines whether CHANNELS are authenticated."
(if (file-exists? cached)
cached
(run-with-store store
- (mlet %store-monad ((profile
- (channel-instances->derivation instances)))
+ (mlet* %store-monad ((instances
+ -> (latest-channel-instances store channels
+ #:authenticate?
+ authenticate?))
+ (profile
+ (channel-instances->derivation instances)))
(mbegin %store-monad
(show-what-to-build* (list profile))
(built-derivations (list profile))
@@ -750,3 +787,7 @@ This is a convenience procedure that people may use in manifests passed to
#:cache-directory cache-directory
#:ttl ttl)))
(open-inferior cached))
+
+;;; Local Variables:
+;;; eval: (put 'memoized 'scheme-indent-function 1)
+;;; End:
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 255b755e6c..1091eee67c 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -61,7 +61,7 @@
gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+
gfl1.0
fdl1.1+ fdl1.2+ fdl1.3+
- opl1.0+
+ opl1.0+ osl2.1
isc
ijg
ibmpl1.0
@@ -78,7 +78,7 @@
mpl1.0 mpl1.1 mpl2.0
ms-pl
ncsa
- npsl
+ nmap
ogl-psi1.0
openldap2.8 openssl
perl-license
@@ -371,6 +371,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"http://opencontent.org/openpub/"
"https://www.gnu.org/licenses/license-list#OpenPublicationL"))
+(define osl2.1
+ (license "The Open Software License 2.1"
+ "https://opensource.org/licenses/osl-2.1.php"
+ "https://www.gnu.org/licenses/license-list#OSL"))
+
(define isc
(license "ISC"
"http://directory.fsf.org/wiki/License:ISC"
@@ -531,10 +536,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..d3deba28bd
--- /dev/null
+++ b/guix/narinfo.scm
@@ -0,0 +1,327 @@
+;;; 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-contents
+
+ 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/profiles.scm b/guix/profiles.scm
index deefce2e26..36cb30c191 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -107,6 +107,8 @@
manifest-search-paths
check-for-collisions
+ manifest->code
+
manifest-transaction
manifest-transaction?
manifest-transaction-install
@@ -667,6 +669,88 @@ including the search path specification for $PATH."
(append-map manifest-entry-search-paths
(manifest-entries manifest)))))
+(define* (manifest->code manifest
+ #:key (entry-package-version (const "")))
+ "Return an sexp representing code to build an approximate version of
+MANIFEST; the code is wrapped in a top-level 'begin' form. Call
+ENTRY-PACKAGE-VERSION to determine the version number to use in the spec for a
+given entry; it can be set to 'manifest-entry-version' for fully-specified
+version numbers, or to some other procedure to disambiguate versions for
+packages for which several versions are available."
+ (define (entry-transformations entry)
+ ;; Return the transformations that apply to ENTRY.
+ (assoc-ref (manifest-entry-properties entry) 'transformations))
+
+ (define transformation-procedures
+ ;; List of transformation options/procedure name pairs.
+ (let loop ((entries (manifest-entries manifest))
+ (counter 1)
+ (result '()))
+ (match entries
+ (() result)
+ ((entry . tail)
+ (match (entry-transformations entry)
+ (#f
+ (loop tail counter result))
+ (options
+ (if (assoc-ref result options)
+ (loop tail counter result)
+ (loop tail (+ 1 counter)
+ (alist-cons options
+ (string->symbol
+ (format #f "transform~a" counter))
+ result)))))))))
+
+ (define (qualified-name entry)
+ ;; Return the name of ENTRY possibly with "@" followed by a version.
+ (match (entry-package-version entry)
+ ("" (manifest-entry-name entry))
+ (version (string-append (manifest-entry-name entry)
+ "@" version))))
+
+ (if (null? transformation-procedures)
+ `(begin ;simplest case
+ (specifications->manifest
+ (list ,@(map (lambda (entry)
+ (match (manifest-entry-output entry)
+ ("out" (qualified-name entry))
+ (output (string-append (qualified-name entry)
+ ":" output))))
+ (manifest-entries manifest)))))
+ (let* ((transform (lambda (options exp)
+ (if (not options)
+ exp
+ (let ((proc (assoc-ref transformation-procedures
+ options)))
+ `(,proc ,exp))))))
+ `(begin ;transformations apply
+ (use-modules (guix transformations))
+
+ ,@(map (match-lambda
+ ((options . name)
+ `(define ,name
+ (options->transformation ',options))))
+ transformation-procedures)
+
+ (packages->manifest
+ (list ,@(map (lambda (entry)
+ (define options
+ (entry-transformations entry))
+
+ (define name
+ (qualified-name entry))
+
+ (match (manifest-entry-output entry)
+ ("out"
+ (transform options
+ `(specification->package ,name)))
+ (output
+ `(list ,(transform
+ options
+ `(specification->package ,name))
+ ,output))))
+ (manifest-entries manifest))))))))
+
;;;
;;; Manifest transactions.
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/describe.scm b/guix/scripts/describe.scm
index c3667516eb..e47d207ee0 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.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 © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
;;;
@@ -113,22 +113,6 @@ Display information about the channels currently in use.\n"))
(_
(warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%")))))))
-(define* (channel->sexp channel #:key (include-introduction? #t))
- (let ((intro (and include-introduction?
- (channel-introduction channel))))
- `(channel
- (name ',(channel-name channel))
- (url ,(channel-url channel))
- (commit ,(channel-commit channel))
- ,@(if intro
- `((introduction (make-channel-introduction
- ,(channel-introduction-first-signed-commit intro)
- (openpgp-fingerprint
- ,(openpgp-format-fingerprint
- (channel-introduction-first-commit-signer
- intro))))))
- '()))))
-
(define (channel->json channel)
(scm->json-string
(let ((intro (channel-introduction channel)))
@@ -183,7 +167,7 @@ string is ~a.~%")
(format #t (G_ " branch: ~a~%") (reference-shorthand head))
(format #t (G_ " commit: ~a~%") commit))
('channels
- (pretty-print `(list ,(channel->sexp (channel (name 'guix)
+ (pretty-print `(list ,(channel->code (channel (name 'guix)
(url (dirname directory))
(commit commit))))))
('json
@@ -213,9 +197,9 @@ in the format specified by FMT."
('human
(display-profile-content profile number))
('channels
- (pretty-print `(list ,@(map channel->sexp channels))))
+ (pretty-print `(list ,@(map channel->code channels))))
('channels-sans-intro
- (pretty-print `(list ,@(map (cut channel->sexp <>
+ (pretty-print `(list ,@(map (cut channel->code <>
#:include-introduction? #f)
channels))))
('json
@@ -237,23 +221,17 @@ way and displaying details about the channel's source code."
(format #t " ~a ~a~%"
(manifest-entry-name entry)
(manifest-entry-version entry))
- (match (assq 'source (manifest-entry-properties entry))
- (('source ('repository ('version 0)
- ('url url)
- ('branch branch)
- ('commit commit)
- _ ...))
- (let ((channel (channel (name 'nameless)
- (url url)
- (branch branch)
- (commit commit))))
- (format #t (G_ " repository URL: ~a~%") url)
- (when branch
- (format #t (G_ " branch: ~a~%") branch))
- (format #t (G_ " commit: ~a~%")
- (if (supports-hyperlinks?)
- (channel-commit-hyperlink channel commit)
- commit))))
+ (match (manifest-entry-channel entry)
+ ((? channel? channel)
+ (format #t (G_ " repository URL: ~a~%")
+ (channel-url channel))
+ (when (channel-branch channel)
+ (format #t (G_ " branch: ~a~%")
+ (channel-branch channel)))
+ (format #t (G_ " commit: ~a~%")
+ (if (supports-hyperlinks?)
+ (channel-commit-hyperlink channel)
+ (channel-commit channel))))
(_ #f)))
;; Show most recently installed packages last.
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/import/json.scm b/guix/scripts/import/json.scm
index 778e5f4bc5..d8d5c3a4af 100644
--- a/guix/scripts/import/json.scm
+++ b/guix/scripts/import/json.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -88,8 +89,13 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n"))
(reverse opts))))
(match args
((file-name)
- (or (json->code file-name)
- (leave (G_ "invalid JSON in file '~a'~%") file-name)))
+ (catch 'system-error
+ (lambda ()
+ (or (json->code file-name)
+ (leave (G_ "invalid JSON in file '~a'~%") file-name)))
+ (lambda args
+ (leave (G_ "failed to access '~a': ~a~%")
+ file-name (strerror (system-error-errno args))))))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 6faf2adb7a..8234a1703d 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, 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 © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
@@ -43,11 +43,13 @@
#:use-module (guix scripts build)
#:use-module (guix transformations)
#:use-module (guix describe)
+ #:autoload (guix channels) (channel-name channel-commit channel->code)
#:autoload (guix store roots) (gc-roots user-owned?)
#:use-module ((guix build utils)
#:select (directory-exists? mkdir-p))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
+ #:autoload (ice-9 pretty-print) (pretty-print)
#:use-module (ice-9 regex)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
@@ -322,6 +324,96 @@ Alternately, see @command{guix package --search-paths -p ~s}.")
;;;
+;;; Export a manifest.
+;;;
+
+(define* (export-manifest manifest
+ #:optional (port (current-output-port)))
+ "Write to PORT a manifest corresponding to MANIFEST."
+ (define (version-spec entry)
+ (let ((name (manifest-entry-name entry)))
+ (match (map package-version (find-packages-by-name name))
+ ((_)
+ ;; A single version of NAME is available, so do not specify the
+ ;; version number, even if the available version doesn't match ENTRY.
+ "")
+ (versions
+ ;; If ENTRY uses the latest version, don't specify any version.
+ ;; Otherwise return the shortest unique version prefix. Note that
+ ;; this is based on the currently available packages, which could
+ ;; differ from the packages available in the revision that was used
+ ;; to build MANIFEST.
+ (let ((current (manifest-entry-version entry)))
+ (if (every (cut version>? current <>)
+ (delete current versions))
+ ""
+ (version-unique-prefix (manifest-entry-version entry)
+ versions)))))))
+
+ (match (manifest->code manifest
+ #:entry-package-version version-spec)
+ (('begin exp ...)
+ (format port (G_ "\
+;; This \"manifest\" file can be passed to 'guix package -m' to reproduce
+;; the content of your profile. This is \"symbolic\": it only specifies
+;; package names. To reproduce the exact same profile, you also need to
+;; capture the channels being used, as returned by \"guix describe\".
+;; See the \"Replicating Guix\" section in the manual.\n"))
+ (for-each (lambda (exp)
+ (newline port)
+ (pretty-print exp port))
+ exp))))
+
+(define (channel=? a b)
+ (and (channel-commit a) (channel-commit b)
+ (string=? (channel-commit a) (channel-commit b))))
+
+(define* (export-channels manifest
+ #:optional (port (current-output-port)))
+ (define channels
+ (delete-duplicates
+ (append-map manifest-entry-provenance (manifest-entries manifest))
+ channel=?))
+
+ (define channel-names
+ (delete-duplicates (map channel-name channels)))
+
+ (define table
+ (fold (lambda (channel table)
+ (vhash-consq (channel-name channel) channel table))
+ vlist-null
+ channels))
+
+ (when (null? channels)
+ (leave (G_ "no provenance information for this profile~%")))
+
+ (format port (G_ "\
+;; This channel file can be passed to 'guix pull -C' or to
+;; 'guix time-machine -C' to obtain the Guix revision that was
+;; used to populate this profile.\n"))
+ (newline port)
+ (display "(list\n" port)
+ (for-each (lambda (name)
+ (define indent " ")
+ (match (vhash-foldq* cons '() name table)
+ ((channel extra ...)
+ (unless (null? extra)
+ (display indent port)
+ (format port (G_ "\
+;; Note: these other commits were also used to install \
+some of the packages in this profile:~%"))
+ (for-each (lambda (channel)
+ (format port "~a;; ~s~%"
+ indent (channel-commit channel)))
+ extra))
+ (pretty-print (channel->code channel) port
+ #:per-line-prefix indent))))
+ channel-names)
+ (display ")\n" port)
+ #t)
+
+
+;;;
;;; Command-line options.
;;;
@@ -374,6 +466,10 @@ Install, remove, or upgrade packages in a single transaction.\n"))
-S, --switch-generation=PATTERN
switch to a generation matching PATTERN"))
(display (G_ "
+ --export-manifest print a manifest for the chosen profile"))
+ (display (G_ "
+ --export-channels print channels for the chosen profile"))
+ (display (G_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
(display (G_ "
--list-profiles list the user's profiles"))
@@ -507,6 +603,14 @@ kind of search path~%")
(values (cons `(query search-paths ,kind)
result)
#f))))
+ (option '("export-manifest") #f #f
+ (lambda (opt name arg result arg-handler)
+ (values (cons `(query export-manifest) result)
+ #f)))
+ (option '("export-channels") #f #f
+ (lambda (opt name arg result arg-handler)
+ (values (cons `(query export-channels) result)
+ #f)))
(option '(#\p "profile") #t #f
(lambda (opt name arg result arg-handler)
(values (alist-cons 'profile (canonicalize-profile arg)
@@ -827,6 +931,18 @@ processed, #f otherwise."
(format #t "~{~a~%~}" settings)
#t))
+ (('export-manifest)
+ (let* ((manifest (concatenate-manifests
+ (map profile-manifest profiles))))
+ (export-manifest manifest (current-output-port))
+ #t))
+
+ (('export-channels)
+ (let ((manifest (concatenate-manifests
+ (map profile-manifest profiles))))
+ (export-channels manifest (current-output-port))
+ #t))
+
(_ #f))))
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/pull.scm b/guix/scripts/pull.scm
index 83cdc1d1eb..4e0ab5d341 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -765,60 +765,61 @@ Use '~/.config/guix/channels.scm' instead."))
#:argument-handler no-arguments))
(substitutes? (assoc-ref opts 'substitutes?))
(dry-run? (assoc-ref opts 'dry-run?))
- (channels (channel-list opts))
(profile (or (assoc-ref opts 'profile) %current-profile))
(current-channels (profile-channels profile))
(validate-pull (assoc-ref opts 'validate-pull))
(authenticate? (assoc-ref opts 'authenticate-channels?)))
- (cond ((assoc-ref opts 'query)
- (process-query opts profile))
- ((assoc-ref opts 'generation)
- (process-generation-change opts profile))
- (else
- (with-store store
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (parameterize ((%current-system (assoc-ref opts 'system))
- (%graft? (assoc-ref opts 'graft?)))
- (with-build-handler (build-notifier #:use-substitutes?
- substitutes?
- #:verbosity
- (assoc-ref opts 'verbosity)
- #:dry-run? dry-run?)
- (set-build-options-from-command-line store opts)
- (ensure-default-profile)
- (honor-x509-certificates store)
-
- (let ((instances
- (latest-channel-instances store channels
- #:current-channels
- current-channels
- #:validate-pull
- validate-pull
- #:authenticate?
- authenticate?)))
- (format (current-error-port)
- (N_ "Building from this channel:~%"
- "Building from these channels:~%"
- (length instances)))
- (for-each (lambda (instance)
- (let ((channel
- (channel-instance-channel instance)))
- (format (current-error-port)
- " ~10a~a\t~a~%"
- (channel-name channel)
- (channel-url channel)
- (string-take
- (channel-instance-commit instance)
- 7))))
- instances)
- (parameterize ((%guile-for-build
- (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (default-guile)))))
- (with-profile-lock profile
- (run-with-store store
- (build-and-install instances profile)))))))))))))))
+ (cond
+ ((assoc-ref opts 'query)
+ (process-query opts profile))
+ ((assoc-ref opts 'generation)
+ (process-generation-change opts profile))
+ (else
+ (with-store store
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (parameterize ((%current-system (assoc-ref opts 'system))
+ (%graft? (assoc-ref opts 'graft?)))
+ (with-build-handler (build-notifier #:use-substitutes?
+ substitutes?
+ #:verbosity
+ (assoc-ref opts 'verbosity)
+ #:dry-run? dry-run?)
+ (set-build-options-from-command-line store opts)
+ (ensure-default-profile)
+ (honor-x509-certificates store)
+
+ (let* ((channels (channel-list opts))
+ (instances
+ (latest-channel-instances store channels
+ #:current-channels
+ current-channels
+ #:validate-pull
+ validate-pull
+ #:authenticate?
+ authenticate?)))
+ (format (current-error-port)
+ (N_ "Building from this channel:~%"
+ "Building from these channels:~%"
+ (length instances)))
+ (for-each (lambda (instance)
+ (let ((channel
+ (channel-instance-channel instance)))
+ (format (current-error-port)
+ " ~10a~a\t~a~%"
+ (channel-name channel)
+ (channel-url channel)
+ (string-take
+ (channel-instance-commit instance)
+ 7))))
+ instances)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (default-guile)))))
+ (with-profile-lock profile
+ (run-with-store store
+ (build-and-install instances profile)))))))))))))))
;;; pull.scm ends here
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..19b8c5163c 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.
@@ -913,7 +915,8 @@ Run 'herd status' to view the list of services on your system.\n"))))))
(let* ((services (operating-system-services os))
(pid1 (fold-services services
#:target-type shepherd-root-service-type))
- (shepherds (service-value pid1)) ;list of <shepherd-service>
+ ;; Get the list of <shepherd-service>.
+ (shepherds (shepherd-configuration-services (service-value pid1)))
(sinks (filter (lambda (service)
(null? (shepherd-service-requirement service)))
shepherds)))
@@ -968,7 +971,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 +997,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 +1017,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 +1146,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 +1338,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 +1371,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/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 5581e12892..39a818dd0b 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -177,9 +177,10 @@ canonical names (symbols)."
upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
services as defined by OS."
(define target-services
- (service-value
- (fold-services (operating-system-services os)
- #:target-type shepherd-root-service-type)))
+ (shepherd-configuration-services
+ (service-value
+ (fold-services (operating-system-services os)
+ #:target-type shepherd-root-service-type))))
(mlet* %store-monad ((live-services (running-services eval)))
(let*-values (((to-unload to-restart)
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/store/database.scm b/guix/store/database.scm
index 0a84bbddb9..8d08def833 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
-;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -53,20 +53,6 @@
;; Name of the file containing the SQL scheme or #f.
(make-parameter #f))
-(define sqlite-exec
- ;; XXX: This is was missing from guile-sqlite3 until
- ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
- (let ((exec (pointer->procedure
- int
- (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))
- '(* * * * *))))
- (lambda (db text)
- (let ((ret (exec ((@@ (sqlite3) db-pointer) db)
- (string->pointer text)
- %null-pointer %null-pointer %null-pointer)))
- (unless (zero? ret)
- ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret))))))
-
(define* (store-database-directory #:key prefix state-directory)
"Return the store database directory, taking PREFIX and STATE-DIRECTORY into
account when provided."
@@ -126,7 +112,7 @@ set journal_mode=WAL."
(lambda ()
(sqlite-close db)))))
-;; XXX: missing in guile-sqlite3@0.1.0
+;; XXX: missing in guile-sqlite3@0.1.2
(define SQLITE_BUSY 5)
(define (call-with-SQLITE_BUSY-retrying thunk)
@@ -139,8 +125,6 @@ errors."
(call-with-SQLITE_BUSY-retrying thunk)
(throw key who code errmsg)))))
-
-
(define* (call-with-transaction db proc #:key restartable?)
"Start a transaction with DB and run PROC. If PROC exits abnormally, abort
the transaction, otherwise commit the transaction after it finishes.
@@ -214,17 +198,6 @@ If FILE doesn't exist, create it and initialize it as a new database. Pass
((_ file db exp ...)
(call-with-database file (lambda (db) exp ...)))))
-(define (sqlite-finalize stmt)
- ;; As of guile-sqlite3 0.1.0, cached statements aren't reset when
- ;; sqlite-finalize is invoked on them (see
- ;; https://notabug.org/guile-sqlite3/guile-sqlite3/issues/12). This can
- ;; cause problems with automatically-started transactions, so we work around
- ;; it by wrapping sqlite-finalize so that sqlite-reset is always called.
- ;; This always works, because resetting a statement twice has no adverse
- ;; effects. We can remove this once the fixed guile-sqlite3 is widespread.
- (sqlite-reset stmt)
- ((@ (sqlite3) sqlite-finalize) stmt))
-
(define (call-with-statement db sql proc)
(let ((stmt (sqlite-prepare db sql #:cache? #t)))
(dynamic-wind
@@ -268,12 +241,26 @@ identifier. Otherwise, return #f."
"INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
VALUES (:path, :hash, :time, :deriver, :size)")
+(define-inlinable (assert-integer proc in-range? key number)
+ (unless (integer? number)
+ (throw 'wrong-type-arg proc
+ "Wrong type argument ~A: ~S" (list key number)
+ (list number)))
+ (unless (in-range? number)
+ (throw 'out-of-range proc
+ "Integer ~A out of range: ~S" (list key number)
+ (list number))))
+
(define* (update-or-insert db #:key path deriver hash nar-size time)
"The classic update-if-exists and insert-if-doesn't feature that sqlite
doesn't exactly have... they've got something close, but it involves deleting
and re-inserting instead of updating, which causes problems with foreign keys,
of course. Returns the row id of the row that was modified or inserted."
+ ;; Make sure NAR-SIZE is valid.
+ (assert-integer "update-or-insert" positive? #:nar-size nar-size)
+ (assert-integer "update-or-insert" (cut >= <> 0) #:time time)
+
;; It's important that querying the path-id and the insert/update operation
;; take place in the same transaction, as otherwise some other
;; process/thread/fiber could register the same path between when we check
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/ui.scm b/guix/ui.scm
index bd504c68da..45ae14f83c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -2124,24 +2124,20 @@ Run COMMAND with ARGS.\n"))
"Run COMMAND with the given ARGS. Report an error when COMMAND is not
found."
(define module
- (catch 'misc-error
- (lambda ()
- (resolve-interface `(guix scripts ,command)))
- (lambda _
- ;; Check if there is a matching extension.
- (catch 'misc-error
- (lambda ()
- (match (search-path (extension-directories)
- (format #f "~a.scm" command))
- (#f
- (throw 'misc-error))
- (file
- (load file)
- (resolve-interface `(guix extensions ,command)))))
- (lambda _
- (format (current-error-port)
- (G_ "guix: ~a: command not found~%") command)
- (show-guix-usage))))))
+ ;; Check if there is a matching extension.
+ (match (search-path (extension-directories)
+ (format #f "~a.scm" command))
+ (#f
+ (catch 'misc-error
+ (lambda ()
+ (resolve-interface `(guix scripts ,command)))
+ (lambda _
+ (format (current-error-port)
+ (G_ "guix: ~a: command not found~%") command)
+ (show-guix-usage))))
+ (file
+ (load file)
+ (resolve-interface `(guix extensions ,command)))))
(let ((command-main (module-ref module
(symbol-append 'guix- command))))
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 678954dbfa..edc3503c10 100644
--- a/guix/utils.scm
+++ b/guix/utils.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 © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
@@ -93,6 +93,7 @@
version-major+minor+point
version-major+minor
version-major
+ version-unique-prefix
guile-version>?
version-prefix?
string-replace-substring
@@ -114,7 +115,6 @@
edit-expression
filtered-port
- compressed-port
decompressed-port
call-with-decompressed-port
compressed-output-port
@@ -215,7 +215,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,
@@ -227,6 +233,8 @@ a symbol such as 'xz."
('gzip (filtered-port `(,%gzip "-dc") input))
('lzip (values (lzip-port 'make-lzip-input-port input)
'()))
+ ('zstd (values (zstd-port 'make-zstd-input-port input)
+ '()))
(_ (error "unsupported compression scheme" compression))))
(define (compressed-port compression input)
@@ -299,6 +307,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
@@ -597,6 +607,38 @@ minor version numbers from version-string."
"Return the major version number as string from the version-string."
(version-prefix version-string 1))
+(define (version-unique-prefix version versions)
+ "Return the shortest version prefix to unambiguously identify VERSION among
+VERSIONS. For example:
+
+ (version-unique-prefix \"2.0\" '(\"3.0\" \"2.0\"))
+ => \"2\"
+
+ (version-unique-prefix \"2.2\" '(\"3.0.5\" \"2.0.9\" \"2.2.7\"))
+ => \"2.2\"
+
+ (version-unique-prefix \"27.1\" '(\"27.1\"))
+ => \"\"
+"
+ (define not-dot
+ (char-set-complement (char-set #\.)))
+
+ (define other-versions
+ (delete version versions))
+
+ (let loop ((prefix '())
+ (components (string-tokenize version not-dot)))
+ (define prefix-str
+ (string-join prefix "."))
+
+ (if (any (cut string-prefix? prefix-str <>) other-versions)
+ (match components
+ ((head . tail)
+ (loop `(,@prefix ,head) tail))
+ (()
+ version))
+ prefix-str)))
+
(define (version>? a b)
"Return #t when A denotes a version strictly newer than B."
(eq? '> (version-compare a b)))