summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-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
12 files changed, 248 insertions, 407 deletions
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)