diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/json.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 118 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 103 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 298 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 26 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 1 |
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) |