summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-04-06 12:10:29 +0200
committerLudovic Courtès <ludo@gnu.org>2021-04-09 17:46:38 +0200
commit2d73086262e1fb33cd0f0f16f74a495fe06b38aa (patch)
tree4811dc7447842b834517ac1bf42127f897197428 /guix/scripts
parentccff3380867b588f0c68e9daedd5728392a91a3f (diff)
daemon: 'guix substitute' replies on FD 4.
This avoids the situation where error messages would unintentionally go to stderr and be wrongfully interpreted as a reply by the daemon. Fixes <https://bugs.gnu.org/46362>. This is a followup to ee3226e9d54891c7e696912245e4904435be191c. * guix/scripts/substitute.scm (display-narinfo-data): Add 'port' parameter and honor it. (process-query): Likewise. (process-substitution): Likewise. (%error-to-file-descriptor-4?, with-redirected-error-port): Remove. (%reply-file-descriptor): New variable. (guix-substitute): Remove use of 'with-redirected-error-port'. Define 'reply-port' and pass it to 'process-query' and 'process-substitution'. * nix/libstore/build.cc (SubstitutionGoal::handleChildOutput): Swap 'builderOut' and 'fromAgent'. * nix/libstore/local-store.cc (LocalStore::getLineFromSubstituter): Likewise. * tests/substitute.scm <top level>: Set '%reply-file-descriptor' rather than '%error-to-file-descriptor-4?'.
Diffstat (limited to 'guix/scripts')
-rwxr-xr-xguix/scripts/substitute.scm191
1 files changed, 89 insertions, 102 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 79eaabd8fd..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?)
@@ -565,10 +565,10 @@ the current output port."
(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)))))))
@@ -682,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)
@@ -719,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)