diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/challenge.scm | 48 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/hexpm.scm | 105 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 34 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/shell.scm | 3 |
6 files changed, 190 insertions, 17 deletions
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index c29d5105ae..5c0f837d13 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix scripts challenge) #:use-module (guix ui) + #:use-module (guix colors) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) @@ -32,6 +33,7 @@ #:use-module (rnrs bytevectors) #:autoload (guix http-client) (http-fetch) #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:autoload (guix build utils) (make-file-writable) #:use-module (gcrypt hash) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -310,6 +312,23 @@ specified in COMPARISON-REPORT." (length files))) (format #t "~{ ~a~%~}" files)))) +(define (make-directory-writable directory) + "Recurse into DIRECTORY and make each entry writable, similar to +'chmod -R +w DIRECTORY'." + (file-system-fold (const #t) + (lambda (file stat _) ;leaf + (unless (eq? 'symlink (stat:type stat)) + (make-file-writable file))) + (lambda (directory stat _) ;down + (make-file-writable directory)) + (const #t) ;up + (const #f) ;skip + (lambda (file stat errno _) ;error + (leave (G_ "failed to delete '~a': ~a~%") + file (strerror errno))) + #t + directory)) + (define (call-with-mismatches comparison-report proc) "Call PROC with two directories containing the mismatching store items." (define local-hash @@ -318,6 +337,13 @@ specified in COMPARISON-REPORT." (define narinfos (comparison-report-narinfos comparison-report)) + (define (restore-file* port directory) + ;; Since 'restore-file' sets "canonical" file permissions (read-only), + ;; make an extra traversal to make DIRECTORY writable so it can be deleted + ;; when the dynamic extent of 'call-with-temporary-directory' is left. + (restore-file port directory) + (make-directory-writable directory)) + (call-with-temporary-directory (lambda (directory1) (call-with-temporary-directory @@ -338,10 +364,10 @@ specified in COMPARISON-REPORT." narinfos))) (rmdir directory1) - (call-with-nar narinfo1 (cut restore-file <> directory1)) + (call-with-nar narinfo1 (cut restore-file* <> directory1)) (when narinfo2 (rmdir directory2) - (call-with-nar narinfo2 (cut restore-file <> directory2))) + (call-with-nar narinfo2 (cut restore-file* <> directory2))) (proc directory1 (if local-hash (comparison-report-item comparison-report) @@ -363,6 +389,11 @@ COMPARISON-REPORT." (append command (list directory1 directory2)))))) +(define good-news + (coloring-procedure (color BOLD GREEN))) +(define bad-news + (coloring-procedure (color BOLD RED))) + (define* (summarize-report comparison-report #:key (report-differences (const #f)) @@ -385,7 +416,7 @@ with COMPARISON-REPORT." (match comparison-report (($ <comparison-report> item 'mismatch local (narinfos ...)) - (report (G_ "~a contents differ:~%") item) + (report (bad-news (G_ "~a contents differ:~%")) item) (report-hashes item local narinfos) (report-differences comparison-report)) (($ <comparison-report> item 'inconclusive #f narinfos) @@ -394,7 +425,7 @@ with COMPARISON-REPORT." (warning (G_ "could not challenge '~a': no substitutes~%") item)) (($ <comparison-report> item 'match local (narinfos ...)) (when verbose? - (report (G_ "~a contents match:~%") item) + (report (good-news (G_ "~a contents match:~%")) item) (report-hashes item local narinfos))))) (define (summarize-report-list reports) @@ -403,10 +434,11 @@ with COMPARISON-REPORT." (inconclusive (count comparison-report-inconclusive? reports)) (matches (count comparison-report-match? reports)) (discrepancies (count comparison-report-mismatch? reports))) - (report (G_ "~h store items were analyzed:~%") total) - (report (G_ " - ~h (~,1f%) were identical~%") + (report (highlight (G_ "~h store items were analyzed:~%")) total) + (report (highlight (G_ " - ~h (~,1f%) were identical~%")) matches (* 100. (/ matches total))) - (report (G_ " - ~h (~,1f%) differed~%") + (report ((if (zero? discrepancies) good-news bad-news) + (G_ " - ~h (~,1f%) differed~%")) discrepancies (* 100. (/ discrepancies total))) (report (G_ " - ~h (~,1f%) were inconclusive~%") inconclusive (* 100. (/ inconclusive total))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 62aa7bdbc5..71ab4b4fed 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -50,7 +50,7 @@ (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest" "elm")) + "minetest" "elm" "hexpm")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/hexpm.scm b/guix/scripts/import/hexpm.scm new file mode 100644 index 0000000000..eb9a1b0af5 --- /dev/null +++ b/guix/scripts/import/hexpm.scm @@ -0,0 +1,105 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020, 2022 Hartmut Goebel <h.goebel@crazy-compilers.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 scripts import hexpm) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import hexpm) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-hexpm)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import hexpm PACKAGE-NAME +Import and convert the hex.pm package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (display (G_ " + -r, --recursive import packages recursively")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import hexpm"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-hexpm . args) + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((spec) + (with-error-handling + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (hexpm-recursive-import name version)) + ;; Single import + (let ((sexp (hexpm->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + spec)) + sexp))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f01764637b..b0cc459d63 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,6 +20,7 @@ (define-module (guix scripts pull) #:use-module ((guix ui) #:hide (display-profile-content)) + #:use-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -786,6 +787,35 @@ Use '~/.config/guix/channels.scm' instead.")) channels)) channels))) +(define (validate-cache-directory-ownership) + "Bail out if the cache directory is not owned by the current user." + (let ((stats dir + (let loop ((dir (cache-directory))) + (let ((stats (stat dir #f))) + (if stats + (values stats dir) + (loop (dirname dir))))))) + (let ((dir:uid (stat:uid stats)) + (our:uid (getuid))) + (unless (= dir:uid our:uid) + (let* ((user (lambda (uid) ;handle the unthinkable invalid UID + (or (false-if-exception (passwd:name + (getpwuid uid))) + uid))) + (our:user (user our:uid)) + (dir:user (user dir:uid))) + (raise + (make-compound-condition + (formatted-message + (G_ "directory '~a' is not owned by user ~a") + dir our:user) + (condition + (&fix-hint + (hint + (format #f (G_ "You should run this command as ~a; use \ +@command{sudo -i} or equivalent if you really want to pull as ~a.") + dir:user our:user))))))))))) + (define-command (guix-pull . args) (synopsis "pull the latest revision of Guix") @@ -810,6 +840,10 @@ Use '~/.config/guix/channels.scm' instead.")) ((assoc-ref opts 'generation) (process-generation-change opts profile)) (else + ;; Bail out early when users accidentally run, e.g., ’sudo guix pull’. + ;; If CACHE-DIRECTORY doesn't yet exist, test where it would end up. + (validate-cache-directory-ownership) + (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 68bb9040d8..4d52200b84 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -46,9 +46,9 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 binary-ports) #:export (guix-refresh)) @@ -315,12 +315,11 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version output source) - (package-update store package updaters - #:key-download key-download)) - ((loc) - (or (package-field-location package 'version) - (package-location package)))) + (let ((version output source + (package-update store package updaters + #:key-download key-download)) + (loc (or (package-field-location package 'version) + (package-location package)))) (when version (if (and=> output file-exists?) (begin diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 1a6df98829..004ed7af2e 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -256,6 +256,7 @@ Return the modified OPTS." ((('package . _) . _) #t) ((('load . _) . _) #t) ((('manifest . _) . _) #t) + ((('profile . _) . _) #t) ((('expression . _) . _) #t) ((_ . rest) (options-contain-payload? rest)))) @@ -465,6 +466,8 @@ concatenates MANIFESTS, a list of expressions." (filter-map (match-lambda (('manifest . file) (load-manifest file)) + (('profile . file) + (profile-manifest file)) (_ #f)) opts))))) (display (G_ "\ |