From f396611776e7ed6f1a070569a338ad56461b099e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 6 Jan 2018 14:43:45 +0100 Subject: publish: Save bandwidth on narinfo 404s. This saves 18 bytes on each 404 narinfo response. * guix/scripts/publish.scm (render-narinfo): Pass #:phrase to 'not-found'. (render-narinfo/cached): Likewise. --- guix/scripts/publish.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index dd54f03996..3f3bc26972 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -326,7 +326,7 @@ advertise it as the maximum validity period (in seconds) via the appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) - (not-found request) + (not-found request #:phrase "") (values `((content-type . (application/x-nix-narinfo)) ,@(if ttl `((cache-control (max-age . ,ttl))) @@ -461,7 +461,7 @@ requested using POOL." #:phrase "We're baking it" #:ttl 300)) ;should be available within 5m (else - (not-found request))))) + (not-found request #:phrase ""))))) (define* (bake-narinfo+nar cache item #:key ttl (compression %no-compression) -- cgit v1.2.3 From 4a8d536ffe4cac1822d9655e0871fdc1684d569b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 7 Jan 2018 22:07:53 +0100 Subject: ui: Display hints that come along with '&message' conditions. * guix/ui.scm (call-with-error-handling): Add case for message and fix-hint?. --- guix/ui.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 6e08a611cd..895179744b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -623,6 +623,12 @@ directories:~{ ~a~}~%") (location->string (error-location c)) (gettext (condition-message c) %gettext-domain)) (exit 1)) + ((and (message-condition? c) (fix-hint? c)) + (format (current-error-port) "~a: error: ~a~%" + (program-name) + (gettext (condition-message c) %gettext-domain)) + (display-hint (condition-fix-hint c)) + (exit 1)) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. (leave (G_ "~a~%") -- cgit v1.2.3 From 896fec476f728183b331cbb6e2afb891207b4205 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 7 Jan 2018 22:13:45 +0100 Subject: ssh: Improve error reporting when retrieving files. 'guix copy --from' now reports messages much more useful than "failed to retrieve files". * guix/ssh.scm (store-export-channel)[export]: Wrap 'use-modules' in 'catch' and 'with-store' in 'guard'. Check for invalid items. Write a status sexp on stdout. (raise-error): New macro. (retrieve-files): Read the initial status sexp and report errors accordingly. --- guix/ssh.scm | 109 +++++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 83 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 7b33ef5a3b..469f4fa6c1 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -19,6 +19,7 @@ (define-module (guix ssh) #:use-module (guix store) #:use-module (guix i18n) + #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ssh session) #:use-module (ssh auth) #:use-module (ssh key) @@ -197,15 +198,36 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." ;; remote store. (define export `(begin - (use-modules (guix)) - - (with-store store - (setvbuf (current-output-port) _IONBF) - - ;; FIXME: Exceptions are silently swallowed. We should report them - ;; somehow. - (export-paths store ',files (current-output-port) - #:recursive? ,recursive?)))) + (eval-when (load expand eval) + (unless (resolve-module '(guix) #:ensure #f) + (write `(module-error)) + (exit 7))) + + (use-modules (guix) (srfi srfi-1) + (srfi srfi-26) (srfi srfi-34)) + + (guard (c ((nix-connection-error? c) + (write `(connection-error ,(nix-connection-error-file c) + ,(nix-connection-error-code c)))) + ((nix-protocol-error? c) + (write `(protocol-error ,(nix-protocol-error-status c) + ,(nix-protocol-error-message c)))) + (else + (write `(exception)))) + (with-store store + (let* ((files ',files) + (invalid (remove (cut valid-path? store <>) + files))) + (unless (null? invalid) + (write `(invalid-items ,invalid)) + (exit 1)) + + (write '(exporting)) ;we're ready + (force-output) + + (setvbuf (current-output-port) _IONBF) + (export-paths store files (current-output-port) + #:recursive? ,recursive?)))))) (open-remote-input-pipe session (string-join @@ -291,6 +313,19 @@ to the length of FILES.)" #:recursive? recursive?) (length files))) ;XXX: inaccurate when RECURSIVE? is true +(define-syntax raise-error + (syntax-rules (=>) + ((_ fmt args ... (=> hint-fmt hint-args ...)) + (raise (condition + (&message + (message (format #f fmt args ...))) + (&fix-hint + (hint (format #f hint-fmt hint-args ...)))))) + ((_ fmt args ...) + (raise (condition + (&message + (message (format #f fmt args ...)))))))) + (define* (retrieve-files local files remote #:key recursive? (log-port (current-error-port))) "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on @@ -298,22 +333,44 @@ LOCAL. When RECURSIVE? is true, retrieve the closure of FILES." (let-values (((port count) (file-retrieval-port files remote #:recursive? recursive?))) - (format #t (N_ "retrieving ~a store item from '~a'...~%" - "retrieving ~a store items from '~a'...~%" count) - count (remote-store-host remote)) - (when (eof-object? (lookahead-u8 port)) - ;; The failure could be because one of the requested store items is not - ;; valid on REMOTE, or because Guile or Guix is improperly installed. - ;; TODO: Improve error reporting. - (raise (condition - (&message - (message - (format #f - (G_ "failed to retrieve store items from '~a'") - (remote-store-host remote))))))) - - (let ((result (import-paths local port))) - (close-port port) - result))) + (match (read port) ;read the initial status + (('exporting) + (format #t (N_ "retrieving ~a store item from '~a'...~%" + "retrieving ~a store items from '~a'...~%" count) + count (remote-store-host remote)) + + (let ((result (import-paths local port))) + (close-port port) + result)) + ((? eof-object?) + (raise-error (G_ "failed to start Guile on remote host '~A': exit code ~A") + (remote-store-host remote) + (channel-get-exit-status port) + (=> (G_ "Make sure @command{guile} can be found in +@code{$PATH} on the remote host. Run @command{ssh ~A guile --version} to +check.") + (remote-store-host remote)))) + (('module-error . _) + ;; TRANSLATORS: Leave "Guile" untranslated. + (raise-error (G_ "Guile modules not found on remote host '~A'") + (remote-store-host remote) + (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix' +own module directory. Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to +check.") + (remote-store-host remote)))) + (('connection-error file code . _) + (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") + file (remote-store-host remote) (strerror code))) + (('invalid-items items . _) + (raise-error (N_ "no such item on remote host '~A':~{ ~a~}" + "no such items on remote host '~A':~{ ~a~}" + (length items)) + (remote-store-host remote) items)) + (('protocol-error status message . _) + (raise-error (G_ "protocol error on remote host '~A': ~a") + (remote-store-host remote) message)) + (_ + (raise-error (G_ "failed to retrieve store items from '~a'") + (remote-store-host remote)))))) ;;; ssh.scm ends here -- cgit v1.2.3 From 29a686688674dc875775305312513405fa396a06 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 5 Jan 2018 17:15:41 +0100 Subject: daemon: Add gzip log compression. * nix/nix-daemon/guix-daemon.cc (GUIX_OPT_LOG_COMPRESSION): New macro. (options): Mark "disable-log-compression" as hidden and add "log-compression". (parse_opt): Handle GUIX_OPT_LOG_COMPRESSION. * nix/libstore/build.cc (DerivationGoal): Add 'gzLogFile'. (openLogFile): Initialize it when 'logCompression' is COMPRESSION_GZIP. (closeLogFile, handleChildOutput): Honor 'gzLogFile'. * nix/libstore/globals.hh (Settings)[compressLog]: Remove. [logCompression]: New field. (CompressionType): New enum. * nix/libstore/globals.cc (Settings::Settings): Initialize it. (update): Remove '_get' call for 'compressLog'. * nix/local.mk (guix_daemon_LDADD, guix_register_LDADD): Add -lz. * guix/store.scm (log-file): Handle '.gz' log files. * tests/guix-daemon.sh: Add test with '--log-compression=gzip'. * doc/guix.texi (Invoking guix-daemon): Adjust accordingly. * config-daemon.ac: Check for libz and zlib.h. --- guix/store.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index e6e45ba89c..89db46b8e6 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -1567,8 +1567,10 @@ must be an absolute store file name, or a derivation file name." "/log/guix/drvs/" (string-take base 2) "/" (string-drop base 2))) + (log.gz (string-append log ".gz")) (log.bz2 (string-append log ".bz2"))) - (cond ((file-exists? log.bz2) log.bz2) + (cond ((file-exists? log.gz) log.gz) + ((file-exists? log.bz2) log.bz2) ((file-exists? log) log) (else #f)))) (else -- cgit v1.2.3 From 152b7beeacb72fe96fd5d3c0fd8b321e247c2c6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 5 Jan 2018 00:15:51 +0100 Subject: publish: Use 'x-raw-file' internal response header. This adjusts the workaround for so that it's not limited to a single content-type. * guix/scripts/publish.scm (render-nar/cached): Add the 'x-raw-file' header on the response. (render-content-addressed-file): Likewise. (with-content-length): Remove the 'x-raw-file' header. (http-write): Instead of dispatching on 'application/octet-stream', check whether 'x-raw-file' is set to determine whether to spawn a thread. --- guix/scripts/publish.scm | 86 +++++++++++++++++++++++++----------------------- 1 file changed, 45 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3f3bc26972..3f73197239 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -544,11 +544,12 @@ return it; otherwise, return 404." #:compression compression))) (if (file-exists? cached) (values `((content-type . (application/octet-stream - (charset . "ISO-8859-1")))) - ;; XXX: We're not returning the actual contents, deferring - ;; instead to 'http-write'. This is a hack to work around - ;; . - cached) + (charset . "ISO-8859-1"))) + ;; XXX: We're not returning the actual contents, deferring + ;; instead to 'http-write'. This is a hack to work around + ;; . + (x-raw-file . ,cached)) + #f) (not-found request)))) (define (render-content-addressed-file store request @@ -562,11 +563,12 @@ has the given HASH of type ALGO." #:recursive? #f))) (if (valid-path? store item) (values `((content-type . (application/octet-stream - (charset . "ISO-8859-1")))) - ;; XXX: We're not returning the actual contents, deferring - ;; instead to 'http-write'. This is a hack to work around - ;; . - item) + (charset . "ISO-8859-1"))) + ;; XXX: We're not returning the actual contents, + ;; deferring instead to 'http-write'. This is a hack to + ;; work around . + (x-raw-file . ,item)) + #f) (not-found request))) (not-found request))) @@ -622,9 +624,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." "Return RESPONSE with a 'content-length' header set to LENGTH." (set-field response (response-headers) (alist-cons 'content-length length - (alist-delete 'content-length - (response-headers response) - eq?)))) + (fold alist-delete + (response-headers response) + '(content-length x-raw-file))))) (define-syntax-rule (swallow-EPIPE exp ...) "Swallow EPIPE errors raised by EXP..." @@ -685,35 +687,37 @@ blocking." (swallow-zlib-error (close-port port)) (values))))) - (('application/octet-stream . _) - ;; Send a raw file in a separate thread. - (call-with-new-thread - (lambda () - (set-thread-name "publish file") - (catch 'system-error - (lambda () - (call-with-input-file (utf8->string body) - (lambda (input) - (let* ((size (stat:size (stat input))) - (response (write-response (with-content-length response - size) - client)) - (output (response-port response))) - (if (file-port? output) - (sendfile output input size) - (dump-port input output)) - (close-port output) - (values))))) - (lambda args - ;; If the file was GC'd behind our back, that's fine. Likewise if - ;; the client closes the connection. - (unless (memv (system-error-errno args) - (list ENOENT EPIPE ECONNRESET)) - (apply throw args)) - (values)))))) (_ - ;; Handle other responses sequentially. - (%http-write server client response body)))) + (match (assoc-ref (response-headers response) 'x-raw-file) + ((? string? file) + ;; Send a raw file in a separate thread. + (call-with-new-thread + (lambda () + (set-thread-name "publish file") + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (input) + (let* ((size (stat:size (stat input))) + (response (write-response (with-content-length response + size) + client)) + (output (response-port response))) + (if (file-port? output) + (sendfile output input size) + (dump-port input output)) + (close-port output) + (values))))) + (lambda args + ;; If the file was GC'd behind our back, that's fine. Likewise if + ;; the client closes the connection. + (unless (memv (system-error-errno args) + (list ENOENT EPIPE ECONNRESET)) + (apply throw args)) + (values)))))) + (#f + ;; Handle other responses sequentially. + (%http-write server client response body)))))) (define-server-impl concurrent-http-server ;; A variant of Guile's built-in HTTP server that offloads possibly long -- cgit v1.2.3 From c04ffadbed7412545555b8be6b78f23eed150d26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 5 Jan 2018 00:19:35 +0100 Subject: publish: Publish build logs. * guix/scripts/publish.scm (render-log-file): New procedure. (make-request-handler): Add "log" case. * tests/publish.scm ("/log/NAME") ("/log/NAME not found"): New tests. * doc/guix.texi (Invoking guix publish): Document /log URLs. --- guix/scripts/publish.scm | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3f73197239..6eb5397c8d 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -572,6 +572,31 @@ has the given HASH of type ALGO." (not-found request))) (not-found request))) +(define (render-log-file store request name) + "Render the log file for NAME, the base name of a store item. Don't attempt +to compress or decompress the log file; just return it as-is." + (define (response-headers file) + ;; XXX: We're not returning the actual contents, deferring instead to + ;; 'http-write'. This is a hack to work around + ;; . + (cond ((string-suffix? ".gz" file) + `((content-type . (text/plain (charset . "UTF-8"))) + (content-encoding . (gzip)) + (x-raw-file . ,file))) + ((string-suffix? ".bz2" file) + `((content-type . (application/x-bzip2 + (charset . "ISO-8859-1"))) + (x-raw-file . ,file))) + (else ;uncompressed + `((content-type . (text/plain (charset . "UTF-8"))) + (x-raw-file . ,file))))) + + (let ((log (log-file store + (string-append (%store-prefix) "/" name)))) + (if log + (values (response-headers log) log) + (not-found request)))) + (define (render-home-page request) "Render the home page." (values `((content-type . (text/html (charset . "UTF-8")))) @@ -772,6 +797,10 @@ blocking." (render-content-addressed-file store request name 'sha256 hash)))) + ;; /log/OUTPUT + (("log" name) + (render-log-file store request name)) + ;; Use different URLs depending on the compression type. This ;; guarantees that /nar URLs remain valid even when 'guix publish' ;; is restarted with different compression parameters. -- cgit v1.2.3 From 1e63ecee0b5e1d7e4894af5a51cceeba0092693c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 8 Jan 2018 11:45:35 +0100 Subject: import: crate: Gracefully deal with missing license info. Reported by Fis Trivial . Fixes . * guix/import/crate.scm (crate-fetch): Check whether the "license" info is present. --- guix/import/crate.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 233a20e983..a7485bb4d0 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -59,7 +59,9 @@ (repository (assoc-ref crate "repository")) (synopsis (assoc-ref crate "description")) (description (assoc-ref crate "description")) - (license (string->license (assoc-ref crate "license"))) + (license (or (and=> (assoc-ref crate "license") + string->license) + '())) ;missing license info (path (string-append "/" version "/dependencies")) (deps-json (json-fetch (string-append crate-url name path))) (deps (assoc-ref deps-json "dependencies")) -- cgit v1.2.3 From 297e04d66010ada31a40f40143d81bf6b62affcc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 9 Jan 2018 22:38:47 +0100 Subject: publish: Remove "Guix-Nar-Compression" header from responses. This was harmless but non-compliant and unnecessary. * guix/scripts/publish.scm : Rename "Guix-Nar-Compression" to "X-Nar-Compression" as should have always been. (render-nar, nar-response-port): Adjust accordingly. (strip-headers): New procedure. (sans-content-length, with-content-length): Use it. --- guix/scripts/publish.scm | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 6eb5397c8d..1673fb9f33 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -505,10 +505,10 @@ requested using POOL." stat:size)) port)))))) -;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for +;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to . -(declare-header! "Guix-Nar-Compression" +(declare-header! "X-Nar-Compression" (lambda (str) (match (call-with-input-string str read) (('compression type level) @@ -529,7 +529,7 @@ requested using POOL." (if (valid-path? store store-path) (values `((content-type . (application/x-nix-archive (charset . "ISO-8859-1"))) - (guix-nar-compression . ,compression)) + (x-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; . @@ -638,20 +638,22 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define %http-write (@@ (web server http) http-write)) +(define (strip-headers response) + "Return RESPONSE's headers minus 'Content-Length' and our internal headers." + (fold alist-delete + (response-headers response) + '(content-length x-raw-file x-nar-compression))) + (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." (set-field response (response-headers) - (alist-delete 'content-length - (response-headers response) - eq?))) + (strip-headers response))) (define (with-content-length response length) "Return RESPONSE with a 'content-length' header set to LENGTH." (set-field response (response-headers) (alist-cons 'content-length length - (fold alist-delete - (response-headers response) - '(content-length x-raw-file))))) + (strip-headers response)))) (define-syntax-rule (swallow-EPIPE exp ...) "Swallow EPIPE errors raised by EXP..." @@ -673,7 +675,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define (nar-response-port response) "Return a port on which to write the body of RESPONSE, the response of a /nar request, according to COMPRESSION." - (match (assoc-ref (response-headers response) 'guix-nar-compression) + (match (assoc-ref (response-headers response) 'x-nar-compression) (($ 'gzip level) ;; Note: We cannot used chunked encoding here because ;; 'make-gzip-output-port' wants a file port. -- cgit v1.2.3 From 828621532663d65f9f8b5d092c9915266d5acf65 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 10 Jan 2018 17:55:37 +0100 Subject: =?UTF-8?q?gnu:=20Use=20one=20spelling=20for=20=E2=80=98copyright?= =?UTF-8?q?=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/gtk.scm: Standardise on ‘copyright’ spelling in file headers. * gnu/packages/pdf.scm: Likewise. * gnu/packages/perl-check.scm: Likewise. * gnu/packages/perl.scm: Likewise. * guix/import/gem.scm: Likewise. * guix/import/hackage.scm: Likewise. --- guix/import/gem.scm | 2 +- guix/import/hackage.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 3ad7facc7f..6e914d6290 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copryight © 2016 Ben Woodcroft +;;; Copyright © 2016 Ben Woodcroft ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 2c9df073d3..4fb00af404 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2016 Eric Bavier -;;; Coypright © 2016 ng0 +;;; Copyright © 2016 ng0 ;;; ;;; This file is part of GNU Guix. ;;; -- cgit v1.2.3 From 17af5d51de7c40756a4a39d336f81681de2ba447 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 10 Jan 2018 17:52:23 +0100 Subject: ssh: Work around 'get-bytevector-some' bug. This works around and noticeably improves performance when using GUIX_DAEMON_SOCKET=ssh://HOST (the redirect code was transferring data to guix-daemon one byte at a time!). * guix/ssh.scm (remote-daemon-channel)[redirect]: Define 'read!' and use it instead of 'get-bytevector-some'. --- guix/ssh.scm | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 469f4fa6c1..96e4af9179 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -101,11 +101,24 @@ Throw an error on failure." ;; Unix-domain sockets but libssh doesn't have an API for that, hence this ;; hack. `(begin - (use-modules (ice-9 match) (rnrs io ports)) + (use-modules (ice-9 match) (rnrs io ports) + (rnrs bytevectors) (system foreign)) + + (define read! + ;; XXX: We would use 'get-bytevector-some' but it always returns a + ;; single byte in Guile <= 2.2.3---see . + ;; This procedure works around it. + (let ((proc (pointer->procedure int + (dynamic-func "read" (dynamic-link)) + (list int '* size_t)))) + (lambda (port bv) + (proc (fileno port) (bytevector->pointer bv) + (bytevector-length bv))))) (let ((sock (socket AF_UNIX SOCK_STREAM 0)) (stdin (current-input-port)) - (stdout (current-output-port))) + (stdout (current-output-port)) + (buffer (make-bytevector 65536))) (setvbuf stdin _IONBF) (setvbuf stdout _IONBF) (connect sock AF_UNIX ,socket-name) @@ -114,17 +127,17 @@ Throw an error on failure." (match (select (list stdin sock) '() (list stdin stdout sock)) ((reads writes ()) (when (memq stdin reads) - (match (get-bytevector-some stdin) - ((? eof-object?) + (match (read! stdin buffer) + ((? zero?) ;EOF (primitive-exit 0)) - (bv - (put-bytevector sock bv)))) + (count + (put-bytevector sock buffer 0 count)))) (when (memq sock reads) - (match (get-bytevector-some sock) - ((? eof-object?) + (match (read! sock buffer) + ((? zero?) ;EOF (primitive-exit 0)) - (bv - (put-bytevector stdout bv)))) + (count + (put-bytevector stdout buffer 0 count)))) (loop)) (_ (primitive-exit 1))))))) -- cgit v1.2.3 From 39d1e9654c102339f3d99b0e52a49639182f972b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 10 Jan 2018 21:38:08 +0100 Subject: store: Fix potential over-reads in 'import-paths'. Previously 'process-stderr' would always pass a bytevector of MAX-LEN to then daemon in the %stderr-read case (i.e., 'import-paths'), instead of LEN (where LEN <= MAX-LEN). In practice the extra bytes didn't cause a protocol violation or anything because they happen at the end of the stream, which typically contains the canonical sexp of the signature, and the extra zeros were just ignored. * guix/serialization.scm (write-bytevector): Add optional 'l' parameter and honor it. * guix/store.scm (process-stderr): Pass LEN to 'write-bytevector'. --- guix/serialization.scm | 8 ++++---- guix/store.scm | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/serialization.scm b/guix/serialization.scm index e6ae2fc307..b41a0a09d1 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -102,9 +102,9 @@ (or (zero? m) (put-bytevector p zero 0 (- 8 m))))))) -(define (write-bytevector s p) - (let* ((l (bytevector-length s)) - (m (modulo l 8)) +(define* (write-bytevector s p + #:optional (l (bytevector-length s))) + (let* ((m (modulo l 8)) (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) (bytevector-u32-set! b 0 l (endianness little)) (bytevector-copy! s 0 b 8 l) diff --git a/guix/store.scm b/guix/store.scm index 89db46b8e6..6742611c6f 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -609,7 +609,7 @@ encoding conversion errors." (let* ((max-len (read-int p)) (data (make-bytevector max-len)) (len (get-bytevector-n! user-port data 0 max-len))) - (write-bytevector data p) + (write-bytevector data p len) #f)) ((= k %stderr-next) ;; Log a string. Build logs are usually UTF-8-encoded, but they -- cgit v1.2.3 From 55f40fdbcdd98d1d1c0110d508079c068bf7f81d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 10 Jan 2018 23:06:08 +0100 Subject: ssh: Pass an empty "exceptfds" set to 'select'. Previously the redirect code could end up exiting prematurely because of an uninteresting "exceptional condition" on the socket (info "(libc) Waiting for I/O"). * guix/ssh.scm (remote-daemon-channel): Pass the empty list as the third argument to 'select'. It was a mistake to pass a non-empty list there in the first place. --- guix/ssh.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 96e4af9179..cb560c0e9c 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -124,8 +124,8 @@ Throw an error on failure." (connect sock AF_UNIX ,socket-name) (let loop () - (match (select (list stdin sock) '() (list stdin stdout sock)) - ((reads writes ()) + (match (select (list stdin sock) '() '()) + ((reads () ()) (when (memq stdin reads) (match (read! stdin buffer) ((? zero?) ;EOF -- cgit v1.2.3 From e21888dd0d0abfb6fa89a2d5b4689e36db238391 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 10 Jan 2018 23:09:05 +0100 Subject: derivations: Fix typo in docstring. * guix/derivations.scm (derivation-prerequisites): Fix typo in docstring. --- guix/derivations.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 97f96d99c1..da686e89e2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -230,7 +230,7 @@ Nix itself keeps only one of them." CUT? is a predicate that is passed a derivation-input and returns true to eliminate the given input and its dependencies from the search. An example of -search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the +such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the result is the set of prerequisites of DRV not already in valid." (let loop ((drv drv) (result '()) -- cgit v1.2.3