diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/challenge.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/locate.scm | 24 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 8 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 61 |
6 files changed, 99 insertions, 20 deletions
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 01e2f9a2b2..d38171b868 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -504,7 +504,6 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (define %default-options `((system . ,(%current-system)) - (substitute-urls . ,%default-substitute-urls) (difference-report . ,report-differing-files))) @@ -539,7 +538,13 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (G_ "no arguments specified, nothing to do~%")) (exit 0)) (x - files)))) + files))) + (urls (or urls + (substitute-urls store) + (begin + (warning (G_ "could not determine current \ +substitute URLs; using defaults~%")) + %default-substitute-urls)))) (set-build-options store #:use-substitutes? #f) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6ae3b11e39..1d7a6e198d 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -311,6 +311,9 @@ use '--preserve' instead~%")) (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by manifest entries for the corresponding packages." + (define system + (assoc-ref opts 'system)) + (define (manifest-entry=? e1 e2) (and (eq? (manifest-entry-item e1) (manifest-entry-item e2)) (string=? (manifest-entry-output e1) @@ -327,11 +330,11 @@ for the corresponding packages." ((? package? package) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package)) - (manifest-entries (package->development-manifest package)))) + (manifest-entries (package->development-manifest package system)))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package output)) - (manifest-entries (package->development-manifest package)))) + (manifest-entries (package->development-manifest package system)))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -345,7 +348,8 @@ for the corresponding packages." (('package 'package (? string? spec)) (manifest-entries (package->development-manifest - (transform (specification->package+output spec))))) + (transform (specification->package+output spec)) + system))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm index 92af3509bf..963ff2bf57 100644 --- a/guix/scripts/locate.scm +++ b/guix/scripts/locate.scm @@ -114,14 +114,24 @@ alter table Packages add column output text; "))) +;; XXX: missing in guile-sqlite3@0.1.3 +(define SQLITE_BUSY 5) + (define (call-with-database file proc) - (let ((db (sqlite-open file))) - (dynamic-wind - (lambda () #t) - (lambda () - (ensure-latest-database-schema db) - (proc db)) - (lambda () (sqlite-close db))))) + (catch 'sqlite-error + (lambda () + (let ((db (sqlite-open file))) + (dynamic-wind + (lambda () #t) + (lambda () + (ensure-latest-database-schema db) + (proc db)) + (lambda () (sqlite-close db))))) + (lambda (key who code errmsg) + (if (= code SQLITE_BUSY) + (leave (G_ "~a: database is locked by another process~%") + file) + (throw key who code errmsg))))) (define (ensure-latest-database-schema db) "Ensure DB follows the latest known version of the schema." diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index bdbea49910..8071840de1 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -137,7 +137,8 @@ dependencies are registered." ;; Make sure non-ASCII file names are properly handled. (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (libc-utf8-locales-for-target (%current-system)) + "/lib/locale")) (setlocale LC_ALL "en_US.utf8") (sql-schema #$schema) @@ -209,7 +210,10 @@ GLIBC-UT8-LOCALES package." (profile-locales? profile)) #~(begin (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (let-system (system target) + (libc-utf8-locales-for-target + (or target system))) + "/lib/locale")) (setlocale LC_ALL "en_US.utf8")) #~(setenv "GUIX_LOCPATH" "unset for tests"))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 126f0f9c69..37cd08e289 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -635,8 +635,9 @@ way to download the nar." (let loop ((cache-urls cache-urls)) (match cache-urls (() - (leave (G_ "failed to find alternative substitute for '~a'~%") - (narinfo-path narinfo))) + (report-error (G_ "failed to find alternative substitute for '~a'~%") + (narinfo-path narinfo)) + (display "not-found\n" port)) ((cache-url rest ...) (match (lookup-narinfos cache-url (list (narinfo-path narinfo)) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 140df3435f..2f8985593d 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> @@ -35,6 +35,8 @@ #:use-module ((guix build utils) #:select (every*)) #:use-module (guix substitutes) #:use-module (guix narinfo) + #:use-module (guix pki) + #:autoload (gcrypt pk-crypto) (canonical-sexp->string) #:use-module (guix http-client) #:use-module (guix ci) #:use-module (guix sets) @@ -185,6 +187,44 @@ or #f if it could not be determined." (() #f))) +(define (check-narinfo-authorization narinfo) + "Print a warning when NARINFO is not signed by an authorized key." + (define acl + (catch 'system-error + (lambda () + (current-acl)) + (lambda args + (warning (G_ "could not read '~a': ~a~%") + %acl-file (strerror (system-error-errno args))) + (warning (G_ "'~a' is unreadable, cannot determine whether \ +substitutes are authorized~%") + %acl-file) + #f))) + + (unless (or (not acl) (valid-narinfo? narinfo acl)) + (warning (G_ "substitutes from '~a' are unauthorized~%") + (narinfo-uri-base narinfo)) + ;; The "all substitutes" below reflects the fact that, in reality, it *is* + ;; possible to download "unauthorized" substitutes, as long as they match + ;; authorized substitutes. + (display-hint (G_ "To authorize all substitutes from @uref{~a} to be +downloaded, the following command needs to be run as root: + +@example +guix archive --authorize <<EOF +~a +EOF +@end example + +Alternatively, on Guix System, you can add the signing key above to the +@code{authorized-keys} field of @code{guix-configuration}. + +See \"Getting Substitutes from Other Servers\" in the manual for more +information.") + (narinfo-uri-base narinfo) + (canonical-sexp->string + (signature-subject (narinfo-signature narinfo)))))) + (define* (report-server-coverage server items #:key display-missing?) "Report the subset of ITEMS available as substitutes on SERVER. @@ -204,6 +244,12 @@ In case ITEMS is an empty list, return 1 instead." #:make-progress-reporter (lambda* (total #:key url #:allow-other-keys) (progress-reporter/bar total))))) + (match narinfos + (() #f) + ((narinfo . _) + ;; Help diagnose missing substitute authorizations. + (check-narinfo-authorization narinfo))) + (let ((obtained (length narinfos)) (requested (length items)) (missing (lset-difference string=? @@ -391,7 +437,7 @@ Report the availability of substitutes.\n")) %standard-native-build-options)) (define %default-options - `((substitute-urls . ,%default-substitute-urls))) + '()) (define (load-manifest file) "Load the manifest from FILE and return the list of packages it refers to." @@ -582,7 +628,16 @@ SERVER. Display information for packages with at least THRESHOLD dependents." (let* ((opts (parse-command-line args %options (list %default-options) #:build-options? #f)) - (urls (assoc-ref opts 'substitute-urls)) + (urls (or (assoc-ref opts 'substitute-urls) + (with-store store + (substitute-urls store)) + (begin + ;; Could not determine the daemon's current + ;; substitute URLs, presumably because it's too + ;; old. + (warning (G_ "using default \ +substitute URLs~%")) + %default-substitute-urls))) (systems (match (filter-map (match-lambda (('system . system) system) (_ #f)) |