diff options
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/archive.scm | 3 | ||||
-rw-r--r-- | guix/scripts/build.scm | 3 | ||||
-rw-r--r-- | guix/scripts/copy.scm | 9 | ||||
-rw-r--r-- | guix/scripts/deploy.scm | 12 | ||||
-rw-r--r-- | guix/scripts/edit.scm | 4 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 3 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 5 | ||||
-rw-r--r-- | guix/scripts/import.scm | 4 | ||||
-rw-r--r-- | guix/scripts/import/egg.scm | 107 | ||||
-rw-r--r-- | guix/scripts/package.scm | 8 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 160 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 11 |
12 files changed, 274 insertions, 55 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index ceac640432..f8678aa5f9 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -260,6 +260,9 @@ build and a list of store files to transfer." resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) + (when (null? files) + (warning (G_ "no arguments specified; creating an empty archive~%"))) + (if (build-derivations store drv) (export-paths store files (current-output-port) #:recursive? (assoc-ref opts 'export-recursive?)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 2decdb45ed..97e2f5a167 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -679,6 +679,9 @@ needed." (_ #f)) opts))) + (when (and (null? drv) (null? items)) + (warning (G_ "no arguments specified, nothing to do~%"))) + (cond ((assoc-ref opts 'log-file?) ;; Pass 'show-build-log' the output file names, not the ;; derivation file names, because there can be several diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 52b476db54..07357af420 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -62,6 +62,10 @@ number (or #f) corresponding to SPEC." (x (leave (G_ "~a: invalid SSH specification~%") spec)))) +(define (warn-if-empty items) + (when (null? items) + (warning (G_ "no arguments specified, nothing to copy~%")))) + (define (send-to-remote-host local target opts) "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; package names, build the underlying packages before sending them." @@ -69,6 +73,7 @@ package names, build the underlying packages before sending them." (ssh-spec->user+host+port target)) ((drv items) (options->derivations+files local opts))) + (warn-if-empty items) (and (build-derivations local drv) (let* ((session (open-ssh-session host #:user user #:port (or port 22))) @@ -94,7 +99,9 @@ package names, build the underlying packages before sending them." (let*-values (((drv items) (options->derivations+files local opts)) ((retrieved) - (retrieve-files local items remote #:recursive? #t))) + (begin + (warn-if-empty items) + (retrieve-files local items remote #:recursive? #t)))) (close-connection remote) (disconnect! session) (format #t "~{~a~%~}" retrieved) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 0725fba54b..7c62b05d12 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson <davet@gnu.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -125,10 +125,7 @@ Perform the deployment specified by FILE.\n")) ;; and include a '&message'. However, that message only contains ;; the format string. Thus, special-case it here to avoid ;; displaying a bare format string. - ((cond-expand - (guile-3 - ((exception-predicate &exception-with-kind-and-args) c)) - (else #f)) + (((exception-predicate &exception-with-kind-and-args) c) (raise c)) ((message-condition? c) @@ -156,7 +153,10 @@ Perform the deployment specified by FILE.\n")) (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) - (machines (or (and file (load-source-file file)) '()))) + (machines (and file (load-source-file file)))) + (unless file + (leave (G_ "missing deployment file argument~%"))) + (show-what-to-deploy machines) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index b4c0507591..a2e1ffb434 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; @@ -91,6 +91,8 @@ line." (with-error-handling (let* ((specs (reverse (parse-arguments))) (locations (map specification->location specs))) + (when (null? specs) + (leave (G_ "no packages specified, nothing to edit~%"))) (catch 'system-error (lambda () diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0360761683..5ceb86f7a9 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -755,6 +755,9 @@ message if any test fails." (> (length (manifest-entries manifest-from-opts)) 0)) (leave (G_ "'--profile' cannot be used with package options~%"))) + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) + (set-build-options-from-command-line store opts) ;; Use the bootstrap Guile when requested. diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index ddfc6ba497..66de824ef4 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -593,6 +593,9 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (read/eval-package-expression exp))) (_ #f)) opts))) + (when (null? items) + (warning (G_ "no arguments specified; creating an empty graph~%"))) + (run-with-store store ;; XXX: Since grafting can trigger unsolicited builds, disable it. (mlet %store-monad ((_ (set-grafting #f)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index bbd9a3b190..f53d1ac1f4 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -76,8 +76,8 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "go" "cran" "crate" "texlive" "json" "opam")) +(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" + "gem" "go" "cran" "crate" "texlive" "json" "opam")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm new file mode 100644 index 0000000000..7dbd6fcd5a --- /dev/null +++ b/guix/scripts/import/egg.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; +;;; 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 egg) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import egg) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-egg)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import egg PACKAGE-NAME +Import and convert the egg package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " + -V, --version display version information and exit")) + (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 egg"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-egg . args) + (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) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (repo (and=> (assoc-ref opts 'repo) string->symbol)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (egg-recursive-import package-name)) + ;; Single import + (let ((sexp (egg->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e3d40d5142..6db83807af 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1044,6 +1044,14 @@ processed, #f otherwise." (warn-about-old-distro) + (when (and (null? files) (manifest-transaction-null? trans)) + ;; We can reach this point because the user did not specify any action + ;; (as in "guix package"), did not specify any package (as in "guix + ;; install"), or because there's nothing to upgrade (as when running + ;; "guix upgrade" on an up-to-date profile). We cannot distinguish + ;; among these here; all we can say is that there's nothing to do. + (warning (G_ "nothing to do~%"))) + (unless (manifest-transaction-null? trans) ;; When '--manifest' is used, display information about TRANS as if we ;; were starting from an empty profile. diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ef6fa5f074..f35f81dc34 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 poll) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:use-module (ice-9 threads) @@ -33,6 +34,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -869,60 +871,115 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." exp ...) (const #f))) -(define (nar-response-port response compression) - "Return a port on which to write the body of RESPONSE, the response of a -/nar request, according to COMPRESSION." +(define (nar-compressed-port port compression) + "Return a port on which to write the body of the response of a /nar request, +according to COMPRESSION." (match compression (($ <compression> 'gzip level) ;; Note: We cannot used chunked encoding here because ;; 'make-gzip-output-port' wants a file port. - (make-gzip-output-port (response-port response) + (make-gzip-output-port port #:level level #:buffer-size %default-buffer-size)) (($ <compression> 'lzip level) - (make-lzip-output-port (response-port response) + (make-lzip-output-port port #:level level)) (($ <compression> 'zstd level) - (make-zstd-output-port (response-port response) + (make-zstd-output-port port #:level level)) (($ <compression> 'none) - (response-port response)) + port) (#f - (response-port response)))) + port))) (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." + ;; XXX: The default Guile web server implementation supports the keep-alive + ;; mechanism. However, as we run our own modified version of the http-write + ;; procedure, we need to access a few server implementation details to keep + ;; it functional. + (define *error-events* + (logior POLLHUP POLLERR)) + + (define *read-events* + POLLIN) + + (define *events* + (logior *error-events* *read-events*)) + + ;; Access the server poll set variable. + (define http-poll-set + (@@ (web server http) http-poll-set)) + + ;; Copied from (web server http). + (define (keep-alive? response) + (let ((v (response-version response))) + (and (or (< (response-code response) 400) + (= (response-code response) 404)) + (case (car v) + ((1) + (case (cdr v) + ((1) (not (memq 'close (response-connection response)))) + ((0) (memq 'keep-alive (response-connection response))))) + (else #f))))) + + (define (keep-alive port) + "Add the given PORT the server poll set." + (force-output port) + (poll-set-add! (http-poll-set server) port *events*)) + + (define compression + (assoc-ref (response-headers response) 'x-nar-compression)) + (match (response-content-type response) (('application/x-nix-archive . _) - ;; Sending the the whole archive can take time so do it in a separate - ;; thread so that the main thread can keep working in the meantime. - (call-with-new-thread - (lambda () - (set-thread-name "publish nar") - (let* ((compression (assoc-ref (response-headers response) - 'x-nar-compression)) - (response (write-response (sans-content-length response) - client)) - (port (begin - (force-output client) - (configure-socket client) - (nar-response-port response compression)))) - ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in - ;; 'render-nar', BODY here is just the file name of the store item. - ;; We call 'write-file' from here because we know that's the only - ;; way to avoid building the whole nar in memory, which could - ;; quickly become a real problem. As a bonus, we even do - ;; sendfile(2) directly from the store files to the socket. - (swallow-zlib-error - (swallow-EPIPE - (write-file (utf8->string body) port))) - (swallow-zlib-error - (close-port port)) - (values))))) + ;; When compressing the NAR on the go, we cannot announce its size + ;; beforehand to the client. Hence, the keep-alive mechanism cannot work + ;; here. + (let ((keep-alive? (and (eq? (compression-type compression) 'none) + (keep-alive? response)))) + ;; Add the client to the server poll set, so that we can receive + ;; further requests without closing the connection. + (when keep-alive? + (keep-alive client)) + ;; Sending the the whole archive can take time so do it in a separate + ;; thread so that the main thread can keep working in the meantime. + (call-with-new-thread + (lambda () + (set-thread-name "publish nar") + (let* ((response (write-response (sans-content-length response) + client)) + (port (begin + (force-output client) + (configure-socket client) + ;; Duplicate the response port, so that it is + ;; not automatically closed when closing the + ;; returned port. This is needed for the + ;; keep-alive mechanism. + (nar-compressed-port + (duplicate-port + (response-port response) "w+0b") + compression)))) + ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> + ;; in 'render-nar', BODY here is just the file name of the store + ;; item. We call 'write-file' from here because we know that's + ;; the only way to avoid building the whole nar in memory, which + ;; could quickly become a real problem. As a bonus, we even do + ;; sendfile(2) directly from the store files to the socket. + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port) + (unless keep-alive? + (close-port client))) + (values)))))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) + (when (keep-alive? response) + (keep-alive client)) ;; Send a raw file in a separate thread. (call-with-new-thread (lambda () @@ -932,19 +989,20 @@ blocking." (call-with-input-file file (lambda (input) (let* ((size (stat:size (stat input))) - (response (write-response (with-content-length response - size) - client)) + (response (write-response + (with-content-length response size) + client)) (output (response-port response))) (configure-socket client) (if (file-port? output) (sendfile output input size) (dump-port input output)) - (close-port output) + (unless (keep-alive? response) + (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. + ;; 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)) @@ -980,6 +1038,18 @@ methods, return the applicable compression." compressions) (default-compression requested-type))) +(define (preserve-connection-headers request response) + "Add REQUEST's 'connection' header, if any, to HEADERS, a list of response +headers." + (if (pair? response) + (let ((connection + (assq 'connection (request-headers request)))) + (append response + (if connection + (list connection) + '()))) + response)) + (define* (make-request-handler store #:key cache pool @@ -993,7 +1063,7 @@ methods, return the applicable compression." (let ((expected (split-and-decode-uri-path nar-path))) (cut equal? expected <>))) - (lambda (request body) + (define (handle request body) (format #t "~a ~a~%" (request-method request) (uri-path (request-uri request))) @@ -1065,7 +1135,15 @@ methods, return the applicable compression." (not-found request))) (x (not-found request))) - (not-found request)))) + (not-found request))) + + ;; Preserve the request's 'connection' header in the response, so that the + ;; server can close the connection if this is requested by the client. + (lambda (request body) + (let-values (((response response-body) + (handle request body))) + (values (preserve-connection-headers request response) + response-body)))) (define (service-name) "Return the Avahi service name of the server." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8e4eae00b3..44448ff3e9 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -163,7 +163,9 @@ if file doesn't exist, and the narinfo otherwise." (define (lookup-narinfo caches path authorized?) "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH was found." - (match (lookup-narinfos/diverse caches (list path) authorized?) + (match (lookup-narinfos/diverse + caches (list path) authorized? + #:open-connection open-connection-for-uri/cached) ((answer) answer) (_ #f))) @@ -518,8 +520,11 @@ PORT." (current-error-port) #:abbreviation nar-uri-abbreviation)))) ;; Keep RAW open upon completion so we can later reuse - ;; the underlying connection. - (progress-report-port reporter raw #:close? #f))) + ;; the underlying connection. Pass the download size so + ;; that this procedure won't block reading from RAW. + (progress-report-port reporter raw + #:close? #f + #:download-size dl-size))) ((input pids) ;; NOTE: This 'progress' port of current process will be ;; closed here, while the child process doing the |