summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorEfraim Flashner <efraim@flashner.co.il>2021-04-16 14:39:48 +0300
committerEfraim Flashner <efraim@flashner.co.il>2021-04-16 14:39:48 +0300
commitfcc39864dba82e14895afbe841091091366c96bc (patch)
tree6e0f05495fd6512051224dc85fd3ab495cbf1a24 /guix/scripts
parent76fc36d0a7215979bb74c05840f5a4de4ab5ea93 (diff)
parent44f9432705d04c069a8acf9e37e3ad856ac0bf82 (diff)
downloadguix-patches-fcc39864dba82e14895afbe841091091366c96bc.tar
guix-patches-fcc39864dba82e14895afbe841091091366c96bc.tar.gz
Merge remote-tracking branch 'origin/master' into core-updates
Conflicts: gnu/local.mk gnu/packages/boost.scm gnu/packages/chez.scm gnu/packages/compression.scm gnu/packages/crates-io.scm gnu/packages/docbook.scm gnu/packages/engineering.scm gnu/packages/gcc.scm gnu/packages/gl.scm gnu/packages/gtk.scm gnu/packages/nettle.scm gnu/packages/python-check.scm gnu/packages/python-xyz.scm gnu/packages/radio.scm gnu/packages/rust.scm gnu/packages/sqlite.scm guix/build-system/node.scm
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/archive.scm4
-rw-r--r--guix/scripts/build.scm2
-rw-r--r--guix/scripts/copy.scm4
-rw-r--r--guix/scripts/describe.scm10
-rw-r--r--guix/scripts/discover.scm12
-rw-r--r--guix/scripts/download.scm17
-rw-r--r--guix/scripts/edit.scm10
-rw-r--r--guix/scripts/import.scm3
-rw-r--r--guix/scripts/import/cran.scm2
-rw-r--r--guix/scripts/import/go.scm75
-rw-r--r--guix/scripts/publish.scm12
-rw-r--r--guix/scripts/repl.scm11
-rw-r--r--guix/scripts/search.scm9
-rw-r--r--guix/scripts/show.scm10
-rwxr-xr-xguix/scripts/substitute.scm200
-rw-r--r--guix/scripts/system.scm2
16 files changed, 188 insertions, 195 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 91be1b02e1..ceac640432 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@@ -63,7 +63,7 @@
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
- (verbosity . 2)
+ (verbosity . 3)
(debug . 0)))
(define (show-help)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index fa1bbf867d..2decdb45ed 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -333,7 +333,7 @@ use '--no-offload' instead~%")))
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
- (verbosity . 2)
+ (verbosity . 3)
(debug . 0)))
(define (show-help)
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 2780d4fbe9..52b476db54 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -163,7 +163,7 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
(debug . 0)
- (verbosity . 2)))
+ (verbosity . 3)))
;;;
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index be2279d254..b5f6249176 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -2,6 +2,7 @@
;;; 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>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -286,12 +287,9 @@ text. The hyperlink links to a web view of COMMIT, when available."
(define-command (guix-describe . args)
(synopsis "describe the channel revisions currently used")
- (let* ((opts (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%")
- name))
- cons
- %default-options))
+ (let* ((opts (parse-command-line args %options (list %default-options)
+ #:build-options? #f
+ #:argument-handler cons))
(format (assq-ref opts 'format))
(profile (or (assq-ref opts 'profile) (current-profile))))
(with-error-handling
diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm
index 6aade81ed1..be1eaa6e95 100644
--- a/guix/scripts/discover.scm
+++ b/guix/scripts/discover.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -127,12 +128,11 @@ to synchronize with the writer."
(synopsis "discover Guix related services using Avahi")
(with-error-handling
- (let* ((opts (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (leave (G_ "~A: extraneous argument~%") arg))
- %default-options))
+ (let* ((opts (parse-command-line args %options (list %default-options)
+ #:build-options? #f
+ #:argument-handler
+ (lambda (arg result)
+ (leave (G_ "~A: extraneous argument~%") arg))))
(cache (assoc-ref opts 'cache))
(publish-file (publish-file cache)))
(parameterize ((%publish-file publish-file))
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index ce8dd8b02c..5a91390358 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -162,15 +163,13 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
(define (parse-options)
;; Return the alist of option values.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (when (assq 'argument result)
- (leave (G_ "~A: extraneous argument~%") arg))
-
- (alist-cons 'argument arg result))
- %default-options))
+ (parse-command-line args %options (list %default-options)
+ #:build-options? #f
+ #:argument-handler
+ (lambda (arg result)
+ (when (assq 'argument result)
+ (leave (G_ "~A: extraneous argument~%") arg))
+ (alist-cons 'argument arg result))))
(with-error-handling
(let* ((opts (parse-options))
diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm
index 49c9d945b6..b4c0507591 100644
--- a/guix/scripts/edit.scm
+++ b/guix/scripts/edit.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -84,11 +84,9 @@ line."
(define (parse-arguments)
;; Return the list of package names.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%") name))
- cons
- '()))
+ (parse-command-line args %options (list (list))
+ #:build-options? #f
+ #:argument-handler cons))
(with-error-handling
(let* ((specs (reverse (parse-arguments)))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 1d2b45d942..98554ef79b 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -119,7 +119,8 @@ Run IMPORTER with ARGS.\n"))
(current-output-port))))))
(match (apply (resolve-importer importer) args)
((and expr (or ('package _ ...)
- ('let _ ...)))
+ ('let _ ...)
+ ('define-public _ ...)))
(print expr))
((? list? expressions)
(for-each (lambda (expr)
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 4767bc082d..aa3ef324e0 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -50,6 +50,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
(display (G_ "
-r, --recursive import packages recursively"))
(display (G_ "
+ -s, --style=STYLE choose output style, either specification or variable"))
+ (display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm
index afdba4e8f1..04b07f80cc 100644
--- a/guix/scripts/import/go.scm
+++ b/guix/scripts/import/go.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,34 +22,38 @@
#:use-module (guix utils)
#:use-module (guix scripts)
#:use-module (guix import go)
+ #:use-module (guix import utils)
#:use-module (guix scripts import)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
+ #:use-module (ice-9 receive)
#:export (guix-import-go))
-
+
;;;
;;; Command-line options.
;;;
(define %default-options
- '())
+ '((goproxy . "https://proxy.golang.org")))
(define (show-help)
- (display (G_ "Usage: guix import go PACKAGE-PATH
-Import and convert the Go module for PACKAGE-PATH.\n"))
+ (display (G_ "Usage: guix import go PACKAGE-PATH[@VERSION]
+Import and convert the Go module for PACKAGE-PATH. Optionally, a version
+can be specified after the arobas (@) character.\n"))
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
- -V, --version display version information and exit"))
- (display (G_ "
- -r, --recursive generate package expressions for all Go modules\
- that are not yet in Guix"))
+ -r, --recursive generate package expressions for all Go modules
+that are not yet in Guix"))
(display (G_ "
-p, --goproxy=GOPROXY specify which goproxy server to use"))
+ (display (G_ "
+ --pin-versions use the exact versions of a module's dependencies"))
(newline)
(show-bug-report-information))
@@ -58,9 +63,6 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
(lambda args
(show-help)
(exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix import go")))
(option '(#\r "recursive") #f #f
(lambda (opt name arg result)
(alist-cons 'recursive #t result)))
@@ -69,9 +71,12 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
(alist-cons 'goproxy
(string->symbol arg)
(alist-delete 'goproxy result))))
+ (option '("pin-versions") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'pin-versions? #t result)))
%standard-import-options))
-
+
;;;
;;; Entry point.
;;;
@@ -91,27 +96,31 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
(('argument . value)
value)
(_ #f))
- (reverse opts))))
+ (reverse opts)))
+ ;; Append the full version to the package symbol name when using
+ ;; pinned versions.
+ (package->definition* (if (assoc-ref opts 'pin-versions?)
+ (cut package->definition <> 'full)
+ package->definition)))
(match args
- ((module-name)
- (if (assoc-ref opts 'recursive)
- (map (match-lambda
- ((and ('package ('name name) . rest) pkg)
- `(define-public ,(string->symbol name)
- ,pkg))
- (_ #f))
- (go-module-recursive-import module-name
- #:goproxy-url
- (or (assoc-ref opts 'goproxy)
- "https://proxy.golang.org")))
- (let ((sexp (go-module->guix-package module-name
- #:goproxy-url
- (or (assoc-ref opts 'goproxy)
- "https://proxy.golang.org"))))
- (unless sexp
- (leave (G_ "failed to download meta-data for module '~a'~%")
- module-name))
- sexp)))
+ ((spec) ;e.g., github.com/golang/protobuf@v1.3.1
+ (receive (name version)
+ (package-name->name+version spec)
+ (let ((arguments (list name
+ #:goproxy (assoc-ref opts 'goproxy)
+ #:version version
+ #:pin-versions?
+ (assoc-ref opts 'pin-versions?))))
+ (if (assoc-ref opts 'recursive)
+ ;; Recursive import.
+ (map package->definition*
+ (apply go-module-recursive-import arguments))
+ ;; Single import.
+ (let ((sexp (apply go-module->guix-package arguments)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for module '~a'~%")
+ module-name))
+ (package->definition* sexp))))))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index fa85088ed0..39bb224cad 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -1117,12 +1118,11 @@ methods, return the applicable compression."
(synopsis "publish build results over HTTP")
(with-error-handling
- (let* ((opts (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (leave (G_ "~A: extraneous argument~%") arg))
- %default-options))
+ (let* ((opts (parse-command-line args %options (list %default-options)
+ #:build-options? #f
+ #:argument-handler
+ (lambda (arg result)
+ (leave (G_ "~A: extraneous argument~%") arg))))
(advertise? (assoc-ref opts 'advertise?))
(user (assoc-ref opts 'user))
(port (assoc-ref opts 'port))
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
index 9f20803efc..50d18c7760 100644
--- a/guix/scripts/repl.scm
+++ b/guix/scripts/repl.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2020 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;;
;;; This file is part of GNU Guix.
@@ -143,14 +143,13 @@ call THUNK."
(synopsis "read-eval-print loop (REPL) for interactive programming")
(define opts
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%") name))
+ (parse-command-line args %options (list %default-options)
+ #:build-options? #f
+ #:argument-handler
(lambda (arg result)
(append `((script . ,arg)
(ignore-dot-guile? . #t))
- result))
- %default-options))
+ result))))
(define user-config
(and=> (getenv "HOME")
diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm
index 0c9e6af07b..27b9da5278 100644
--- a/guix/scripts/search.scm
+++ b/guix/scripts/search.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -66,11 +67,9 @@ This is an alias for 'guix package -s'.\n"))
result))
(define opts
- (args-fold* args %options
- (lambda (opt name arg . rest)
- (leave (G_ "~A: unrecognized option~%") name))
- handle-argument
- '()))
+ (parse-command-line args %options (list (list))
+ #:build-options? #f
+ #:argument-handler handle-argument))
(unless (assoc-ref opts 'query)
(leave (G_ "missing arguments: no regular expressions to search for~%")))
diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm
index 535d03c1a6..c747eedd21 100644
--- a/guix/scripts/show.scm
+++ b/guix/scripts/show.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2019, 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -66,11 +66,9 @@ This is an alias for 'guix package --show='.\n"))
result))
(define opts
- (args-fold* args %options
- (lambda (opt name arg . rest)
- (leave (G_ "~A: unrecognized option~%") name))
- handle-argument
- '()))
+ (parse-command-line args %options (list (list))
+ #:build-options? #f
+ #:argument-handler handle-argument))
(unless (assoc-ref opts 'query)
(leave (G_ "missing arguments: no package to show~%")))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 46323c7216..48309f9b3a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -63,7 +63,7 @@
#:use-module (web uri)
#:use-module (guix http-client)
#:export (%allow-unauthenticated-substitutes?
- %error-to-file-descriptor-4?
+ %reply-file-descriptor
substitute-urls
guix-substitute))
@@ -279,29 +279,29 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
"Evaluate EXP... Return its CPU usage as a fraction between 0 and 1."
(call-with-cpu-usage-monitoring (lambda () exp ...)))
-(define (display-narinfo-data narinfo)
- "Write to the current output port the contents of NARINFO in the format
-expected by the daemon."
- (format #t "~a\n~a\n~a\n"
+(define (display-narinfo-data port narinfo)
+ "Write to PORT the contents of NARINFO in the format expected by the
+daemon."
+ (format port "~a\n~a\n~a\n"
(narinfo-path narinfo)
(or (and=> (narinfo-deriver narinfo)
(cute string-append (%store-prefix) "/" <>))
"")
(length (narinfo-references narinfo)))
- (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
+ (for-each (cute format port "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo))
(let-values (((uri compression file-size)
(narinfo-best-uri narinfo
#:fast-decompression?
%prefer-fast-decompression?)))
- (format #t "~a\n~a\n"
+ (format port "~a\n~a\n"
(or file-size 0)
(or (narinfo-size narinfo) 0))))
-(define* (process-query command
+(define* (process-query port command
#:key cache-urls acl)
- "Reply to COMMAND, a query as written by the daemon to this process's
+ "Reply on PORT 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?
@@ -338,17 +338,17 @@ authorized substitutes."
#:open-connection open-connection-for-uri/cached
#:make-progress-reporter make-progress-reporter)))
(for-each (lambda (narinfo)
- (format #t "~a~%" (narinfo-path narinfo)))
+ (format port "~a~%" (narinfo-path narinfo)))
substitutable)
- (newline)))
+ (newline port)))
(("info" paths ..1)
;; Reply info about PATHS if it's in CACHE-URLS.
(let ((substitutable (lookup-narinfos/diverse
cache-urls paths valid?
#:open-connection open-connection-for-uri/cached
#:make-progress-reporter make-progress-reporter)))
- (for-each display-narinfo-data substitutable)
- (newline)))
+ (for-each (cut display-narinfo-data port <>) substitutable)
+ (newline port)))
(wtf
(error "unknown `--query' command" wtf))))
@@ -428,14 +428,14 @@ server certificates."
"Bind PORT with EXP... to a socket connected to URI."
(call-with-cached-connection uri (lambda (port) exp ...)))
-(define* (process-substitution store-item destination
+(define* (process-substitution port store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL, and verify its
hash against what appears in the narinfo. When DEDUPLICATE? is true, and if
-DESTINATION is in the store, deduplicate its files. Print a status line on
-the current output port."
+DESTINATION is in the store, deduplicate its files. Print a status line to
+PORT."
(define narinfo
(lookup-narinfo cache-urls store-item
(if (%allow-unauthenticated-substitutes?)
@@ -555,17 +555,20 @@ the current output port."
(every (compose zero? cdr waitpid) pids)
;; Skip a line after what 'progress-reporter/file' printed, and another
- ;; one to visually separate substitutions.
- (display "\n\n" (current-error-port))
+ ;; one to visually separate substitutions. When PRINT-BUILD-TRACE? is
+ ;; true, leave it up to (guix status) to prettify things.
+ (newline (current-error-port))
+ (unless print-build-trace?
+ (newline (current-error-port)))
;; Check whether we got the data announced in NARINFO.
(let ((actual (get-hash)))
(if (bytevector=? actual expected)
;; Tell the daemon that we're done.
- (format (current-output-port) "success ~a ~a~%"
+ (format port "success ~a ~a~%"
(narinfo-hash narinfo) (narinfo-size narinfo))
;; The actual data has a different hash than that in NARINFO.
- (format (current-output-port) "hash-mismatch ~a ~a ~a~%"
+ (format port "hash-mismatch ~a ~a ~a~%"
(hash-algorithm-name algorithm)
(bytevector->nix-base32-string expected)
(bytevector->nix-base32-string actual)))))))
@@ -655,7 +658,7 @@ is shorter than MAX elements, then it is directly returned."
;; If the following option is passed to the daemon, use the substitutes list
;; provided by "guix discover" process.
(let* ((option (find-daemon-option "discover"))
- (discover? (and option (string=? option "yes"))))
+ (discover? (and option (string=? option "true"))))
(if discover?
(randomize-substitute-urls (read-substitute-urls))
'())))
@@ -679,28 +682,10 @@ default value."
(unless (string->uri uri)
(leave (G_ "~a: invalid URI~%") uri)))
-(define %error-to-file-descriptor-4?
- ;; Whether to direct 'current-error-port' to file descriptor 4 like
- ;; 'guix-daemon' expects.
- (make-parameter #t))
-
-;; The daemon's agent code opens file descriptor 4 for us and this is where
-;; stderr should go.
-(define-syntax-rule (with-redirected-error-port exp ...)
- "Evaluate EXP... with the current error port redirected to file descriptor 4
-if needed, as expected by the daemon's agent."
- (let ((thunk (lambda () exp ...)))
- (if (%error-to-file-descriptor-4?)
- (parameterize ((current-error-port (fdopen 4 "wl")))
- ;; Redirect diagnostics to file descriptor 4 as well.
- (guix-warning-port (current-error-port))
-
- ;; 'with-continuation-barrier' captures the initial value of
- ;; 'current-error-port' to report backtraces in case of uncaught
- ;; exceptions. Without it, backtraces would be printed to FD 2,
- ;; thereby confusing the daemon.
- (with-continuation-barrier thunk))
- (thunk))))
+(define %reply-file-descriptor
+ ;; The file descriptor where replies to the daemon must be sent, or #f to
+ ;; use the current output port instead.
+ (make-parameter 4))
(define-command (guix-substitute . args)
(category internal)
@@ -716,68 +701,73 @@ if needed, as expected by the daemon's agent."
(define deduplicate?
(find-daemon-option "deduplicate"))
- (with-redirected-error-port
- (mkdir-p %narinfo-cache-directory)
- (maybe-remove-expired-cache-entries %narinfo-cache-directory
- cached-narinfo-files
- #:entry-expiration
- cached-narinfo-expiration-time
- #:cleanup-period
- %narinfo-expired-cache-entry-removal-delay)
- (check-acl-initialized)
-
- ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error
- ;; message.
- (for-each validate-uri (substitute-urls))
-
- ;; Attempt to install the client's locale so that messages are suitably
- ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default
- ;; so don't change it.
- (match (or (find-daemon-option "untrusted-locale")
- (find-daemon-option "locale"))
- (#f #f)
- (locale (false-if-exception (setlocale LC_MESSAGES locale))))
-
- (catch 'system-error
- (lambda ()
- (set-thread-name "guix substitute"))
- (const #t)) ;GNU/Hurd lacks 'prctl'
-
- (with-networking
- (with-error-handling ; for signature errors
- (match args
- (("--query")
- (let ((acl (current-acl)))
- (let loop ((command (read-line)))
- (or (eof-object? command)
- (begin
- (process-query command
- #:cache-urls (substitute-urls)
- #:acl acl)
- (loop (read-line)))))))
- (("--substitute")
- ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
- ;; Specify the number of columns of the terminal so the progress
- ;; report displays nicely.
- (parameterize ((current-terminal-columns (client-terminal-columns)))
- (let loop ()
- (match (read-line)
- ((? eof-object?)
- #t)
- ((= string-tokenize ("substitute" store-path destination))
- (process-substitution store-path destination
- #:cache-urls (substitute-urls)
- #:acl (current-acl)
- #:deduplicate? deduplicate?
- #:print-build-trace?
- print-build-trace?)
- (loop))))))
- ((or ("-V") ("--version"))
- (show-version-and-exit "guix substitute"))
- (("--help")
- (show-help))
- (opts
- (leave (G_ "~a: unrecognized options~%") opts)))))))
+ (define reply-port
+ ;; Port used to reply to the daemon.
+ (if (%reply-file-descriptor)
+ (fdopen (%reply-file-descriptor) "wl")
+ (current-output-port)))
+
+ (mkdir-p %narinfo-cache-directory)
+ (maybe-remove-expired-cache-entries %narinfo-cache-directory
+ cached-narinfo-files
+ #:entry-expiration
+ cached-narinfo-expiration-time
+ #:cleanup-period
+ %narinfo-expired-cache-entry-removal-delay)
+ (check-acl-initialized)
+
+ ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error
+ ;; message.
+ (for-each validate-uri (substitute-urls))
+
+ ;; Attempt to install the client's locale so that messages are suitably
+ ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default
+ ;; so don't change it.
+ (match (or (find-daemon-option "untrusted-locale")
+ (find-daemon-option "locale"))
+ (#f #f)
+ (locale (false-if-exception (setlocale LC_MESSAGES locale))))
+
+ (catch 'system-error
+ (lambda ()
+ (set-thread-name "guix substitute"))
+ (const #t)) ;GNU/Hurd lacks 'prctl'
+
+ (with-networking
+ (with-error-handling ; for signature errors
+ (match args
+ (("--query")
+ (let ((acl (current-acl)))
+ (let loop ((command (read-line)))
+ (or (eof-object? command)
+ (begin
+ (process-query reply-port command
+ #:cache-urls (substitute-urls)
+ #:acl acl)
+ (loop (read-line)))))))
+ (("--substitute")
+ ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
+ ;; Specify the number of columns of the terminal so the progress
+ ;; report displays nicely.
+ (parameterize ((current-terminal-columns (client-terminal-columns)))
+ (let loop ()
+ (match (read-line)
+ ((? eof-object?)
+ #t)
+ ((= string-tokenize ("substitute" store-path destination))
+ (process-substitution reply-port store-path destination
+ #:cache-urls (substitute-urls)
+ #:acl (current-acl)
+ #:deduplicate? deduplicate?
+ #:print-build-trace?
+ print-build-trace?)
+ (loop))))))
+ ((or ("-V") ("--version"))
+ (show-version-and-exit "guix substitute"))
+ (("--help")
+ (show-help))
+ (opts
+ (leave (G_ "~a: unrecognized options~%") opts))))))
;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index c226f08371..0a051ee4e3 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1145,7 +1145,7 @@ Some ACTIONS support additional ARGS.\n"))
"Return the verbosity level based on OPTS, the alist of parsed options."
(or (assoc-ref opts 'verbosity)
(if (eq? (assoc-ref opts 'action) 'build)
- 2 1)))
+ 3 1)))
;;;