From 21531add3205e400707c8fbfd841845f9a71863a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Mar 2014 22:39:48 +0100 Subject: offload: Use Guile-SSH instead of GNU lsh. * guix/scripts/offload.scm ()[ssh-options]: Remove. [host-key, host-key-type]: New fields. (%lsh-command, %lshg-command, user-lsh-private-key): Remove. (user-openssh-private-key, private-key-from-file*): New procedures. (host-key->type+key, open-ssh-session): New procedures. (remote-pipe): Remove 'mode' parameter. Rewrite in terms of 'open-ssh-session' etc. Update users. (send-files)[missing-files]: Rewrite using the bidirectional channel port. Remove call to 'call-with-compressed-output-port'. (retrieve-files): Remove call to 'call-with-decompressed-port'. (machine-load): Remove exit status logic. * doc/guix.texi (Requirements): Mention Guile-SSH. (Daemon Offload Setup): Document 'host-key' and 'private-key'. Show the default value on each @item line. * m4/guix.m4 (GUIX_CHECK_GUILE_SSH): New macro. * config-daemon.ac: Use 'GUIX_CHECK_GUILE_SSH'. Set 'HAVE_DAEMON_OFFLOAD_HOOK' as a function of that. --- guix/scripts/offload.scm | 279 ++++++++++++++++++++++------------------------- 1 file changed, 133 insertions(+), 146 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 33d141e7ef..327c99dfea 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -17,6 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts offload) + #:use-module (ssh key) + #:use-module (ssh auth) + #:use-module (ssh session) + #:use-module (ssh channel) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -65,14 +69,13 @@ (define-record-type* (system build-machine-system) ; string (user build-machine-user) ; string (private-key build-machine-private-key ; file name - (default (user-lsh-private-key))) + (default (user-openssh-private-key))) + (host-key build-machine-host-key) ; string (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real (default 1.0)) (features build-machine-features ; list of strings - (default '())) - (ssh-options build-machine-ssh-options ; list of strings (default '()))) (define-record-type* @@ -86,19 +89,11 @@ (define %machine-file ;; File that lists machines available as build slaves. (string-append %config-directory "/machines.scm")) -(define %lsh-command - "lsh") - -(define %lshg-command - ;; FIXME: 'lshg' fails to pass large amounts of data, see - ;; . - "lsh") - -(define (user-lsh-private-key) - "Return the user's default lsh private key, or #f if it could not be +(define (user-openssh-private-key) + "Return the user's default SSH private key, or #f if it could not be determined." (and=> (getenv "HOME") - (cut string-append <> "/.lsh/identity"))) + (cut string-append <> "/.ssh/id_rsa"))) (define %user-module ;; Module in which the machine description file is loaded. @@ -134,60 +129,79 @@ (define* (build-machines #:optional (file %machine-file)) (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -;;; FIXME: The idea was to open the connection to MACHINE once for all, but -;;; lshg is currently non-functional. -;; (define (open-ssh-gateway machine) -;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the -;; running lsh gateway upon success, or #f on failure." -;; (catch 'system-error -;; (lambda () -;; (let* ((port (open-pipe* OPEN_READ %lsh-command -;; "-l" (build-machine-user machine) -;; "-i" (build-machine-private-key machine) -;; ;; XXX: With lsh 2.1, passing '--write-pid' -;; ;; last causes the PID not to be printed. -;; "--write-pid" "--gateway" "--background" -;; (build-machine-name machine))) -;; (line (read-line port)) -;; (status (close-pipe port))) -;; (if (zero? status) -;; (let ((pid (string->number line))) -;; (if (integer? pid) -;; pid -;; (begin -;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") -;; %lsh-command line) -;; #f))) -;; (begin -;; (warning (_ "failed to initiate SSH connection to '~a':\ -;; '~a' exited with ~a~%") -;; (build-machine-name machine) -;; %lsh-command -;; (status:exit-val status)) -;; #f)))) -;; (lambda args -;; (leave (_ "failed to execute '~a': ~a~%") -;; %lsh-command (strerror (system-error-errno args)))))) - -(define-syntax with-error-to-port - (syntax-rules () - ((_ port exp0 exp ...) - (let ((new port) - (old (current-error-port))) - (dynamic-wind - (lambda () - (set-current-error-port new)) - (lambda () - exp0 exp ...) - (lambda () - (set-current-error-port old))))))) - -(define* (remote-pipe machine mode command - #:key (error-port (current-error-port)) (quote? #t)) - "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been -set up. When QUOTE? is true, perform shell-quotation of all the elements of -COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could -not be started." +(define (host-key->type+key host-key) + "Destructure HOST-KEY, an OpenSSH host key string, and return two values: +its key type as a symbol, and the actual base64-encoded string." + (define (type->symbol type) + (and (string-prefix? "ssh-" type) + (string->symbol (string-drop type 4)))) + + (match (string-tokenize host-key) + ((type key _) + (values (type->symbol type) key)) + ((type key) + (values (type->symbol type) key)))) + +(define (private-key-from-file* file) + "Like 'private-key-from-file', but raise an error that 'with-error-handling' +can interpret meaningfully." + (catch 'guile-ssh-error + (lambda () + (private-key-from-file file)) + (lambda (key proc str . rest) + (raise (condition + (&message (message (format #f (_ "failed to load SSH \ +private key from '~a': ~a") + file str)))))))) + +(define (open-ssh-session machine) + "Open an SSH session for MACHINE and return it. Throw an error on failure." + (let ((private (private-key-from-file* (build-machine-private-key machine))) + (public (public-key-from-file + (string-append (build-machine-private-key machine) + ".pub"))) + (session (make-session #:user (build-machine-user machine) + #:host (build-machine-name machine) + #:port (build-machine-port machine) + #:timeout 5 ;seconds + ;; #:log-verbosity 'protocol + #:identity (build-machine-private-key machine) + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression "zlib" + #:compression-level 3))) + (connect! session) + + ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about + ;; ed25519 keys and 'get-key-type' returns #f in that case. + (let-values (((server) (get-server-public-key session)) + ((type key) (host-key->type+key + (build-machine-host-key machine)))) + (unless (and (or (not (get-key-type server)) + (eq? (get-key-type server) type)) + (string=? (public-key->string server) key)) + ;; Key mismatch: something's wrong. XXX: It could be that the server + ;; provided its Ed25519 key when we where expecting its RSA key. + (leave (_ "server at '~a' returned host key '~a' of type '~a' \ +instead of '~a' of type '~a'~%") + (build-machine-name machine) + (public-key->string server) (get-key-type server) + key type))) + + (let ((auth (userauth-public-key! session private))) + (unless (eq? 'success auth) + (disconnect! session) + (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (build-machine-name machine) (get-error session)))) + + session)) + +(define* (remote-pipe machine command + #:key (quote? #t)) + "Run COMMAND (a list) on MACHINE, and return an open input/output port, +which is also an SSH channel. When QUOTE? is true, perform shell-quotation of +all the elements of COMMAND." (define (shell-quote str) ;; Sort-of shell-quote STR so it can be passed as an argument to the ;; shell. @@ -195,20 +209,15 @@ (define (shell-quote str) (lambda () (write str)))) - ;; Let the child inherit ERROR-PORT. - (with-error-to-port error-port - (apply open-pipe* mode %lshg-command - "-l" (build-machine-user machine) - "-p" (number->string (build-machine-port machine)) - - ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. - "-i" (build-machine-private-key machine) - - (append (build-machine-ssh-options machine) - (list (build-machine-name machine)) - (if quote? - (map shell-quote command) - command))))) + ;; TODO: Use (ssh popen) instead. + (let* ((session (open-ssh-session machine)) + (channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel + (string-join (if quote? + (map shell-quote command) + command))) + channel)) ;;; @@ -335,10 +344,11 @@ (define script (unless (= EEXIST (system-error-errno args)) (apply throw args))))))) - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guile" "-c" ,(object->string script))))) (read-string pipe) - (let ((status (close-pipe pipe))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) (unless (zero? status) ;; Better be safe than sorry: if we ignore the error here, then FILE ;; may be GC'd just before we start using it. @@ -367,10 +377,10 @@ (define script (false-if-exception (delete-file file))) roots))))) - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guile" "-c" ,(object->string script))))) (read-string pipe) - (close-pipe pipe))) + (close-port pipe))) (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) @@ -384,7 +394,7 @@ (define* (offload drv machine ;; Normally DRV has already been protected from GC when it was transferred. ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guix" "build" "-r" ,%gc-root-file ,(format #f "--max-silent-time=~a" @@ -397,14 +407,20 @@ (define* (offload drv machine ;; Since 'guix build' writes the build log to its ;; stderr, everything will go directly to LOG-PORT. - #:error-port log-port))) + ;; #:error-port log-port ;; FIXME + ))) + ;; Make standard error visible. + (channel-set-stream! pipe 'stderr) + (let loop ((line (read-line pipe))) (unless (eof-object? line) (display line log-port) (newline log-port) (loop (read-line pipe)))) - (close-pipe pipe))) + (let loop ((status (channel-get-exit-status pipe))) + (close-port pipe) + status))) (define* (transfer-and-offload drv machine #:key @@ -438,7 +454,7 @@ (define* (transfer-and-offload drv machine with exit code ~a~%" (derivation-file-name drv) (build-machine-name machine) - (status:exit-val status)) + status) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -448,24 +464,14 @@ (define (send-files files machine) "Send the subset of FILES that's missing to MACHINE's store. Return #t on success, #f otherwise." (define (missing-files files) - ;; Return the subset of FILES not already on MACHINE. - (let*-values (((files) - (format #f "~{~a~%~}" files)) - ((missing pids) - (filtered-port - (append (list (which %lshg-command) - "-l" (build-machine-user machine) - "-p" (number->string - (build-machine-port machine)) - "-i" (build-machine-private-key machine)) - (build-machine-ssh-options machine) - (cons (build-machine-name machine) - '("guix" "archive" "--missing"))) - (open-input-string files))) - ((result) - (read-string missing))) - (for-each waitpid pids) - (string-tokenize result))) + ;; Return the subset of FILES not already on MACHINE. Use 'head' as a + ;; hack to make sure the remote end stops reading when we're done. + (let* ((pipe (remote-pipe machine + `("guix" "archive" "--missing") + #:quote? #f))) + (format pipe "~{~a~%~}" files) + (channel-send-eof pipe) + (string-tokenize (read-string pipe)))) (with-store store (guard (c ((nix-protocol-error? c) @@ -476,40 +482,28 @@ (define (missing-files files) ;; Compute the subset of FILES missing on MACHINE, and send them in ;; topologically sorted order so that they can actually be imported. - ;; - ;; To reduce load on the machine that's offloading (since it's typically - ;; already quite busy, see hydra.gnu.org), compress with gzip rather - ;; than xz: For a compression ratio 2 times larger, it is 20 times - ;; faster. (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine OPEN_WRITE - '("gzip" "-dc" "|" - "guix" "archive" "--import") + (pipe (remote-pipe machine + '("guix" "archive" "--import") #:quote? #f))) (format #t (_ "sending ~a store files to '~a'...~%") (length files) (build-machine-name machine)) - (call-with-compressed-output-port 'gzip pipe - (lambda (compressed) - (catch 'system-error - (lambda () - (export-paths store files compressed)) - (lambda args - (warning (_ "failed while exporting files to '~a': ~a~%") - (build-machine-name machine) - (strerror (system-error-errno args)))))) - #:options '("--fast")) - - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe)))))) + + (export-paths store files pipe) + (channel-send-eof pipe) + + ;; Wait for the remote process to complete. + (let ((status (channel-get-exit-status pipe))) + (close pipe) + status))))) (define (retrieve-files files machine) "Retrieve FILES from MACHINE's store, and import them." (define host (build-machine-name machine)) - (let ((pipe (remote-pipe machine OPEN_READ - `("guix" "archive" "--export" ,@files - "|" "xz" "-c") + (let ((pipe (remote-pipe machine + `("guix" "archive" "--export" ,@files) #:quote? #f))) (and pipe (with-store store @@ -522,14 +516,11 @@ (define host ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. - (call-with-decompressed-port 'xz pipe - (lambda (decompressed) - (restore-file-set decompressed - #:log-port (current-error-port) - #:lock? #f))) + (restore-file-set pipe + #:log-port (current-error-port) + #:lock? #f) - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe))))))) + (close-port pipe)))))) ;;; @@ -547,13 +538,9 @@ (define (machine-matches? machine requirements) (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." - (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) - (line (read-line pipe)) - (status (close-pipe pipe))) - (unless (eqv? 0 (status:exit-val status)) - (warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%") - (build-machine-name machine) - (status:exit-val status))) + (let* ((pipe (remote-pipe machine '("cat" "/proc/loadavg"))) + (line (read-line pipe))) + (close-port pipe) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded -- cgit v1.2.3 From 9e76eed37fc4cb0f70c1cc1441dfba92b25c33eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Nov 2016 12:00:47 +0100 Subject: offload: Reuse SSH session during 'transfer-and-offload'. * guix/scripts/offload.scm (remote-pipe): Replace 'machine' parameter with 'session'. Remove 'open-ssh-session' call. (register-gc-root): Replace 'machine' with 'session'. Use ' session-get' instead of 'build-machine-name'. (remove-gc-roots, offload, send-files, retrieve-files): Likewise. (transfer-and-offload): Add 'open-ssh-session' call. Handle 'offload' errors here. (machine-load): Add call to 'open-ssh-session'. --- guix/scripts/offload.scm | 84 +++++++++++++++++++++++++----------------------- 1 file changed, 43 insertions(+), 41 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 327c99dfea..8704743a7f 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -197,9 +197,9 @@ (define (open-ssh-session machine) session)) -(define* (remote-pipe machine command +(define* (remote-pipe session command #:key (quote? #t)) - "Run COMMAND (a list) on MACHINE, and return an open input/output port, + "Run COMMAND (a list) on SESSION, and return an open input/output port, which is also an SSH channel. When QUOTE? is true, perform shell-quotation of all the elements of COMMAND." (define (shell-quote str) @@ -209,9 +209,7 @@ (define (shell-quote str) (lambda () (write str)))) - ;; TODO: Use (ssh popen) instead. - (let* ((session (open-ssh-session machine)) - (channel (make-channel session))) + (let* ((channel (make-channel session))) (channel-open-session channel) (channel-request-exec channel (string-join (if quote? @@ -312,8 +310,9 @@ (define %gc-root-file ;; File name of the temporary GC root we install. (format #f "offload-~a-~a" (gethostname) (getpid))) -(define (register-gc-root file machine) - "Mark FILE, a store item, as a garbage collector root on MACHINE." +(define (register-gc-root file session) + "Mark FILE, a store item, as a garbage collector root in SESSION. Return +the exit status, zero on success." (define script `(begin (use-modules (guix config)) @@ -344,7 +343,7 @@ (define script (unless (= EEXIST (system-error-errno args)) (apply throw args))))))) - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guile" "-c" ,(object->string script))))) (read-string pipe) (let ((status (channel-get-exit-status pipe))) @@ -353,10 +352,10 @@ (define script ;; Better be safe than sorry: if we ignore the error here, then FILE ;; may be GC'd just before we start using it. (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") - file (build-machine-name machine) status))))) + file (session-get session 'host) status))))) -(define (remove-gc-roots machine) - "Remove from MACHINE the GC roots previously installed with +(define (remove-gc-roots session) + "Remove in SESSION the GC roots previously installed with 'register-gc-root'." (define script `(begin @@ -377,24 +376,19 @@ (define script (false-if-exception (delete-file file))) roots))))) - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guile" "-c" ,(object->string script))))) (read-string pipe) (close-port pipe))) -(define* (offload drv machine +(define* (offload drv session #:key print-build-trace? (max-silent-time 3600) build-timeout (log-port (build-log-port))) - "Perform DRV on MACHINE, assuming DRV and its prerequisites are available + "Perform DRV in SESSION, assuming DRV and its prerequisites are available there, and write the build log to LOG-PORT. Return the exit status." - (format (current-error-port) "offloading '~a' to '~a'...~%" - (derivation-file-name drv) (build-machine-name machine)) - (format (current-error-port) "@ build-remote ~a ~a~%" - (derivation-file-name drv) (build-machine-name machine)) - ;; Normally DRV has already been protected from GC when it was transferred. ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guix" "build" "-r" ,%gc-root-file ,(format #f "--max-silent-time=~a" @@ -432,23 +426,31 @@ (define* (transfer-and-offload drv machine "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from MACHINE." + (define session + (open-ssh-session machine)) + (when (begin - (register-gc-root (derivation-file-name drv) machine) + (register-gc-root (derivation-file-name drv) session) (send-files (cons (derivation-file-name drv) inputs) - machine)) - (let ((status (offload drv machine + session)) + (format (current-error-port) "offloading '~a' to '~a'...~%" + (derivation-file-name drv) (build-machine-name machine)) + (format (current-error-port) "@ build-remote ~a ~a~%" + (derivation-file-name drv) (build-machine-name machine)) + + (let ((status (offload drv session #:print-build-trace? print-build-trace? #:max-silent-time max-silent-time #:build-timeout build-timeout))) (if (zero? status) (begin - (retrieve-files outputs machine) - (remove-gc-roots machine) + (retrieve-files outputs session) + (remove-gc-roots session) (format (current-error-port) "done with offloaded '~a'~%" (derivation-file-name drv))) (begin - (remove-gc-roots machine) + (remove-gc-roots session) (format (current-error-port) "derivation '~a' offloaded to '~a' failed \ with exit code ~a~%" @@ -460,13 +462,13 @@ (define* (transfer-and-offload drv machine ;; interprets other non-zero codes as transient build failures. (primitive-exit 100)))))) -(define (send-files files machine) - "Send the subset of FILES that's missing to MACHINE's store. Return #t on +(define (send-files files session) + "Send the subset of FILES that's missing to SESSION's store. Return #t on success, #f otherwise." (define (missing-files files) - ;; Return the subset of FILES not already on MACHINE. Use 'head' as a + ;; Return the subset of FILES not already on SESSION. Use 'head' as a ;; hack to make sure the remote end stops reading when we're done. - (let* ((pipe (remote-pipe machine + (let* ((pipe (remote-pipe session `("guix" "archive" "--missing") #:quote? #f))) (format pipe "~{~a~%~}" files) @@ -476,18 +478,17 @@ (define (missing-files files) (with-store store (guard (c ((nix-protocol-error? c) (warning (_ "failed to export files for '~a': ~s~%") - (build-machine-name machine) - c) + (session-get session 'host) c) #f)) - ;; Compute the subset of FILES missing on MACHINE, and send them in + ;; Compute the subset of FILES missing on SESSION, and send them in ;; topologically sorted order so that they can actually be imported. (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine + (pipe (remote-pipe session '("guix" "archive" "--import") #:quote? #f))) (format #t (_ "sending ~a store files to '~a'...~%") - (length files) (build-machine-name machine)) + (length files) (session-get session 'host)) (export-paths store files pipe) (channel-send-eof pipe) @@ -497,12 +498,12 @@ (define (missing-files files) (close pipe) status))))) -(define (retrieve-files files machine) - "Retrieve FILES from MACHINE's store, and import them." +(define (retrieve-files files session) + "Retrieve FILES from SESSION's store, and import them." (define host - (build-machine-name machine)) + (session-get session 'host)) - (let ((pipe (remote-pipe machine + (let ((pipe (remote-pipe session `("guix" "archive" "--export" ,@files) #:quote? #f))) (and pipe @@ -538,8 +539,9 @@ (define (machine-matches? machine requirements) (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." - (let* ((pipe (remote-pipe machine '("cat" "/proc/loadavg"))) - (line (read-line pipe))) + (let* ((session (open-ssh-session machine)) + (pipe (remote-pipe session '("cat" "/proc/loadavg"))) + (line (read-line pipe))) (close-port pipe) (if (eof-object? line) -- cgit v1.2.3 From e8a5db80d5fe2e603d7b72c3b3cc5ba6ea6d99d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Nov 2016 00:46:04 +0100 Subject: offload: Remove 'with-nar-error-handling' macro. * guix/scripts/offload.scm (with-nar-error-handling): Remove. (guix-offload): Use 'with-error-handling' instead. --- guix/scripts/offload.scm | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 8704743a7f..35286ab9d5 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -664,17 +664,6 @@ (define* (process-request wants-local? system drv features ;; Not now, all the machines are busy. (display "# postpone\n"))))))) -(define-syntax-rule (with-nar-error-handling body ...) - "Execute BODY with any &nar-error suitably reported to the user." - (guard (c ((nar-error? c) - (let ((file (nar-error-file c))) - (if (condition-has-type? c &message) - (leave (_ "while importing file '~a': ~a~%") - file (gettext (condition-message c))) - (leave (_ "failed to import file '~a'~%") - file))))) - body ...)) - ;;; ;;; Entry point. @@ -705,7 +694,7 @@ (define not-coma (cond ((regexp-exec request-line-rx line) => (lambda (match) - (with-nar-error-handling + (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system (call-with-input-file -- cgit v1.2.3 From cf283dd92eb5ef2dee4b761bb23f6dca2525cd55 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Nov 2016 00:47:34 +0100 Subject: offload: Rewrite to make direct RPCs to the remote daemon. * guix/scripts/offload.scm ()[daemon-socket]: New field. (connect-to-remote-daemon): New procedure. (%gc-root-file, register-gc-root, remove-gc-roots, offload): Remove. (transfer-and-offload): Rewrite using 'connect-to-remote-daemon' and RPCs over SSH. (store-import-channel, store-export-channel): New procedures. (send-files, retrieve-files): Rewrite using these. --- doc/guix.texi | 4 + guix/scripts/offload.scm | 371 ++++++++++++++++++++++------------------------- 2 files changed, 175 insertions(+), 200 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index f1cb007aa9..b8e37055e6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -921,6 +921,10 @@ Port number of SSH server on the machine. The SSH private key file to use when connecting to the machine, in OpenSSH format. +@item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"}) +File name of the Unix-domain socket @command{guix-daemon} is listening +to on that machine. + @item @code{parallel-builds} (default: @code{1}) The number of builds that may run in parallel on the machine. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 35286ab9d5..1821bb5b7a 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -21,6 +21,9 @@ (define-module (guix scripts offload) #:use-module (ssh auth) #:use-module (ssh session) #:use-module (ssh channel) + #:use-module (ssh popen) + #:use-module (ssh dist) + #:use-module (ssh dist node) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -71,6 +74,8 @@ (define-record-type* (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) (host-key build-machine-host-key) ; string + (daemon-socket build-machine-daemon-socket ; string + (default "/var/guix/daemon-socket/socket")) (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -197,6 +202,53 @@ (define (open-ssh-session machine) session)) +(define* (connect-to-remote-daemon session + #:optional + (socket-name "/var/guix/daemon-socket/socket")) + "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, +an SSH session. Return a object." + (define redirect + ;; Code run in SESSION to redirect the remote process' stdin/stdout to the + ;; daemon's socket, à la socat. The SSH protocol supports forwarding to + ;; Unix-domain sockets but libssh doesn't have an API for that, hence this + ;; hack. + `(begin + (use-modules (ice-9 match) (rnrs io ports)) + + (let ((sock (socket AF_UNIX SOCK_STREAM 0)) + (stdin (current-input-port)) + (stdout (current-output-port))) + (setvbuf stdin _IONBF) + (setvbuf stdout _IONBF) + (connect sock AF_UNIX ,socket-name) + + (let loop () + (match (select (list stdin sock) '() (list stdin stdout sock)) + ((reads writes ()) + (when (memq stdin reads) + (match (get-bytevector-some stdin) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector sock bv)))) + (when (memq sock reads) + (match (get-bytevector-some sock) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector stdout bv)))) + (loop)) + (_ + (primitive-exit 1))))))) + + (let ((channel + (open-remote-pipe* session OPEN_BOTH + ;; Sort-of shell-quote REDIRECT. + "guile" "-c" + (object->string + (object->string redirect))))) + (open-connection #:port channel))) + (define* (remote-pipe session command #:key (quote? #t)) "Run COMMAND (a list) on SESSION, and return an open input/output port, @@ -306,116 +358,6 @@ (define (build-log-port) (set-port-revealed! port 1) port)) -(define %gc-root-file - ;; File name of the temporary GC root we install. - (format #f "offload-~a-~a" (gethostname) (getpid))) - -(define (register-gc-root file session) - "Mark FILE, a store item, as a garbage collector root in SESSION. Return -the exit status, zero on success." - (define script - `(begin - (use-modules (guix config)) - - ;; Note: we can't use 'add-indirect-root' because dangling links under - ;; gcroots/auto are automatically deleted by the GC. This strategy - ;; doesn't have this problem, but it requires write access to that - ;; directory. - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (catch 'system-error - (lambda () - (mkdir root-directory)) - (lambda args - (unless (= EEXIST (system-error-errno args)) - (error "failed to create remote GC root directory" - root-directory (system-error-errno args))))) - - (catch 'system-error - (lambda () - (symlink ,file - (string-append root-directory "/" ,%gc-root-file))) - (lambda args - ;; If FILE already exists, we can assume that either it's a stale - ;; reference (which is fine), or another process is already - ;; building the derivation represented by FILE (which is fine - ;; too.) Thus, do nothing in that case. - (unless (= EEXIST (system-error-errno args)) - (apply throw args))))))) - - (let ((pipe (remote-pipe session - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (let ((status (channel-get-exit-status pipe))) - (close-port pipe) - (unless (zero? status) - ;; Better be safe than sorry: if we ignore the error here, then FILE - ;; may be GC'd just before we start using it. - (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") - file (session-get session 'host) status))))) - -(define (remove-gc-roots session) - "Remove in SESSION the GC roots previously installed with -'register-gc-root'." - (define script - `(begin - (use-modules (guix config) (ice-9 ftw) - (srfi srfi-1) (srfi srfi-26)) - - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (false-if-exception - (delete-file - (string-append root-directory "/" ,%gc-root-file))) - - ;; These ones were created with 'guix build -r' (there can be more - ;; than one in case of multiple-output derivations.) - (let ((roots (filter (cut string-prefix? ,%gc-root-file <>) - (scandir ".")))) - (for-each (lambda (file) - (false-if-exception (delete-file file))) - roots))))) - - (let ((pipe (remote-pipe session - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (close-port pipe))) - -(define* (offload drv session - #:key print-build-trace? (max-silent-time 3600) - build-timeout (log-port (build-log-port))) - "Perform DRV in SESSION, assuming DRV and its prerequisites are available -there, and write the build log to LOG-PORT. Return the exit status." - ;; Normally DRV has already been protected from GC when it was transferred. - ;; The '-r' flag below prevents the build result from being GC'd. - (let ((pipe (remote-pipe session - `("guix" "build" - "-r" ,%gc-root-file - ,(format #f "--max-silent-time=~a" - max-silent-time) - ,@(if build-timeout - (list (format #f "--timeout=~a" - build-timeout)) - '()) - ,(derivation-file-name drv)) - - ;; Since 'guix build' writes the build log to its - ;; stderr, everything will go directly to LOG-PORT. - ;; #:error-port log-port ;; FIXME - ))) - ;; Make standard error visible. - (channel-set-stream! pipe 'stderr) - - (let loop ((line (read-line pipe))) - (unless (eof-object? line) - (display line log-port) - (newline log-port) - (loop (read-line pipe)))) - - (let loop ((status (channel-get-exit-status pipe))) - (close-port pipe) - status))) - (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -429,99 +371,128 @@ (define* (transfer-and-offload drv machine (define session (open-ssh-session machine)) - (when (begin - (register-gc-root (derivation-file-name drv) session) - (send-files (cons (derivation-file-name drv) inputs) - session)) - (format (current-error-port) "offloading '~a' to '~a'...~%" - (derivation-file-name drv) (build-machine-name machine)) - (format (current-error-port) "@ build-remote ~a ~a~%" - (derivation-file-name drv) (build-machine-name machine)) - - (let ((status (offload drv session - #:print-build-trace? print-build-trace? - #:max-silent-time max-silent-time - #:build-timeout build-timeout))) - (if (zero? status) - (begin - (retrieve-files outputs session) - (remove-gc-roots session) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (remove-gc-roots session) - (format (current-error-port) - "derivation '~a' offloaded to '~a' failed \ -with exit code ~a~%" - (derivation-file-name drv) - (build-machine-name machine) - status) - - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100)))))) - -(define (send-files files session) - "Send the subset of FILES that's missing to SESSION's store. Return #t on -success, #f otherwise." - (define (missing-files files) - ;; Return the subset of FILES not already on SESSION. Use 'head' as a - ;; hack to make sure the remote end stops reading when we're done. - (let* ((pipe (remote-pipe session - `("guix" "archive" "--missing") - #:quote? #f))) - (format pipe "~{~a~%~}" files) - (channel-send-eof pipe) - (string-tokenize (read-string pipe)))) + (define store + (connect-to-remote-daemon session + (build-machine-daemon-socket machine))) + + (set-build-options store + #:print-build-trace print-build-trace? + #:max-silent-time max-silent-time + #:timeout build-timeout) + + ;; Protect DRV from garbage collection. + (add-temp-root store (derivation-file-name drv)) + + (send-files (cons (derivation-file-name drv) inputs) + store) + (format (current-error-port) "offloading '~a' to '~a'...~%" + (derivation-file-name drv) (build-machine-name machine)) + (format (current-error-port) "@ build-remote ~a ~a~%" + (derivation-file-name drv) (build-machine-name machine)) + + (guard (c ((nix-protocol-error? c) + (format (current-error-port) + (_ "derivation '~a' offloaded to '~a' failed: ~a~%") + (derivation-file-name drv) + (build-machine-name machine) + (nix-protocol-error-message c)) + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (primitive-exit 100))) + (build-derivations store (list drv))) + + (retrieve-files outputs store) + (format (current-error-port) "done with offloaded '~a'~%" + (derivation-file-name drv))) + +(define (store-import-channel session) + "Return an output port to which archives to be exported to SESSION's store +can be written." + ;; Using the 'import-paths' RPC on a remote store would be slow because it + ;; makes a round trip every time 32 KiB have been transferred. This + ;; procedure instead opens a separate channel to use the remote + ;; 'import-paths' procedure, which consumes all the data in a single round + ;; trip. + (define import + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-input-port) _IONBF) + (import-paths store (current-input-port))))) + + (open-remote-output-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string import)))))) + +(define (store-export-channel session files) + "Return an input port from which an export of FILES from SESSION's store can +be read." + ;; Same as above: this is more efficient than calling 'export-paths' on a + ;; remote store. + (define export + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-output-port) _IONBF) + (export-paths store ',files (current-output-port))))) + + (open-remote-input-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string export)))))) +(define (send-files files remote) + "Send the subset of FILES that's missing to REMOTE, a remote store." (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to export files for '~a': ~s~%") - (session-get session 'host) c) - #f)) - - ;; Compute the subset of FILES missing on SESSION, and send them in - ;; topologically sorted order so that they can actually be imported. - (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe session - '("guix" "archive" "--import") - #:quote? #f))) - (format #t (_ "sending ~a store files to '~a'...~%") - (length files) (session-get session 'host)) - - (export-paths store files pipe) - (channel-send-eof pipe) - - ;; Wait for the remote process to complete. - (let ((status (channel-get-exit-status pipe))) - (close pipe) - status))))) - -(define (retrieve-files files session) + ;; Compute the subset of FILES missing on SESSION, and send them in + ;; topologically sorted order so that they can actually be imported. + (let* ((sorted (topologically-sorted store files)) + (session (channel-get-session (nix-server-socket remote))) + (node (make-node session)) + (missing (node-eval node + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',sorted))))) + (port (store-import-channel session))) + (format #t (_ "sending ~a store files to '~a'...~%") + (length missing) (session-get session 'host)) + + (export-paths store missing port) + + ;; Tell the remote process that we're done. (In theory the + ;; end-of-archive mark of 'export-paths' would be enough, but in + ;; practice it's not.) + (channel-send-eof port) + + ;; Wait for completion of the remote process. + (let ((result (zero? (channel-get-exit-status port)))) + (close-port port) + result)))) + +(define (retrieve-files files remote) "Retrieve FILES from SESSION's store, and import them." - (define host - (session-get session 'host)) - - (let ((pipe (remote-pipe session - `("guix" "archive" "--export" ,@files) - #:quote? #f))) - (and pipe - (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to import files from '~a': ~s~%") - host c) - #f)) - (format (current-error-port) "retrieving ~a files from '~a'...~%" - (length files) host) - - ;; We cannot use the 'import-paths' RPC here because we already - ;; hold the locks for FILES. - (restore-file-set pipe - #:log-port (current-error-port) - #:lock? #f) - - (close-port pipe)))))) + (let* ((session (channel-get-session (nix-server-socket remote))) + (host (session-get session 'host)) + (port (store-export-channel session files))) + (format #t (_ "retrieving ~a files from '~a'...~%") + (length files) host) + + ;; We cannot use the 'import-paths' RPC here because we already + ;; hold the locks for FILES. + (let ((result (restore-file-set port + #:log-port (current-error-port) + #:lock? #f))) + (close-port port) + result))) ;;; -- cgit v1.2.3 From bc1ad4e334fbf5239ed8d617751e9fa7dbe0ab23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Nov 2016 22:47:37 +0100 Subject: offload: Drop 'remote-pipe'. * guix/scripts/offload.scm (remote-pipe): Remove. (machine-load): Use 'open-remote-pipe*' instead of 'remote-pipe'. --- guix/scripts/offload.scm | 23 ++--------------------- 1 file changed, 2 insertions(+), 21 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1821bb5b7a..2e0268020c 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -249,26 +249,6 @@ (define redirect (object->string redirect))))) (open-connection #:port channel))) -(define* (remote-pipe session command - #:key (quote? #t)) - "Run COMMAND (a list) on SESSION, and return an open input/output port, -which is also an SSH channel. When QUOTE? is true, perform shell-quotation of -all the elements of COMMAND." - (define (shell-quote str) - ;; Sort-of shell-quote STR so it can be passed as an argument to the - ;; shell. - (with-output-to-string - (lambda () - (write str)))) - - (let* ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel - (string-join (if quote? - (map shell-quote command) - command))) - channel)) - ;;; ;;; Synchronization. @@ -511,7 +491,8 @@ (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." (let* ((session (open-ssh-session machine)) - (pipe (remote-pipe session '("cat" "/proc/loadavg"))) + (pipe (open-remote-pipe* session OPEN_READ + "cat" "/proc/loadavg")) (line (read-line pipe))) (close-port pipe) -- cgit v1.2.3 From 1cd1d8a7ea43bfb99aa05c74da5430bb3d8a4309 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Nov 2016 23:00:36 +0100 Subject: offload: Call 'machine-load' only once per machine. This fixes a longstanding issue where 'choose-build-machine' would make on average O(N log(N)) calls to 'machine-load', plus an extra call for the selected machine, instead of N calls. * guix/scripts/offload.scm (machine-load): Add comment. (machine-power-factor, machine-less-loaded-or-faster?): Remove. (choose-build-machine)[machines+slots]: Rename to... [machines+slots+loads]: ... this. [undecorate]: Adjust accordingly. [machine-less-loaded-or-faster?]: New procedure. Remove extra 'machine-load' call in body. --- guix/scripts/offload.scm | 46 +++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 2e0268020c..bc024a8701 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -490,6 +490,7 @@ (define (machine-matches? machine requirements) (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." + ;; Note: This procedure is costly since it creates a new SSH session. (let* ((session (open-ssh-session machine)) (pipe (open-remote-pipe* session OPEN_READ "cat" "/proc/loadavg")) @@ -510,17 +511,6 @@ (define (machine-load machine) (_ +inf.0))))) ;something's fishy about MACHINE, so avoid it -(define (machine-power-factor m) - "Return a factor that aggregates the speed and load of M. The higher the -better." - (/ (build-machine-speed m) - (+ 1 (machine-load m)))) - -(define (machine-less-loaded-or-faster? m1 m2) - "Return #t if M1 is either less loaded or faster than M2. (This relation -defines a total order on machines.)" - (> (machine-power-factor m1) (machine-power-factor m2))) - (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." (string-append %state-directory "/offload/" @@ -548,29 +538,39 @@ (define (choose-build-machine machines) ;; 5. Release the global machine-choice lock. (with-file-lock (machine-choice-lock-file) - (define machines+slots + (define machines+slots+loads (filter-map (lambda (machine) + ;; Call 'machine-load' from here to make sure it is called + ;; only once per machine (it is expensive). (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) + (and slot + (list machine slot (machine-load machine))))) machines)) (define (undecorate pred) (lambda (a b) (match a - ((machine1 slot1) + ((machine1 slot1 load1) (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (let loop ((machines+slots - (sort machines+slots + ((machine2 slot2 load2) + (pred machine1 load1 machine2 load2))))))) + + (define (machine-less-loaded-or-faster? m1 l1 m2 l2) + ;; Return #t if M1 is either less loaded or faster than M2, with L1 + ;; being the load of M1 and L2 the load of M2. (This relation defines a + ;; total order on machines.) + (> (/ (build-machine-speed m1) (+ 1 l1)) + (/ (build-machine-speed m2) (+ 1 l2)))) + + (let loop ((machines+slots+loads + (sort machines+slots+loads (undecorate machine-less-loaded-or-faster?)))) - (match machines+slots - (((best slot) others ...) + (match machines+slots+loads + (((best slot load) others ...) ;; Return the best machine unless it's already overloaded. - (if (< (machine-load best) 2.) + (if (< load 2.) (match others - (((machines slots) ...) + (((machines slots loads) ...) ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) -- cgit v1.2.3 From e9c72306fdfd6a60158918850cb25d0ff3837d16 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Nov 2016 15:07:07 +0100 Subject: refresh: Warn about packages that lack an updater. * guix/upstream.scm (package-update-path): Rename to... (package-latest-release): ... this. Remove 'version>?' check. (package-latest-release*): New procedure. (package-update): Use it. * guix/scripts/refresh.scm (lookup-updater): Rename to... (lookup-updater-by-name): ... this. (warn-no-updater): New procedure. (update-package): Add #:warn? parameter and honor it. (check-for-package-update): New procedure. (guix-refresh)[warn?]: New variable. Replace inline code when UPDATE? is false with a call to 'check-for-package-update'. Pass WARN? to 'check-for-package-update' and 'update-package'. * doc/guix.texi (Invoking guix refresh): Document it. Fix a couple of typos. --- doc/guix.texi | 19 +++++++--- guix/scripts/refresh.scm | 96 ++++++++++++++++++++++++++++++------------------ guix/upstream.scm | 30 ++++++++++----- 3 files changed, 95 insertions(+), 50 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index ce1e5d075a..4677e5cf79 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5250,10 +5250,19 @@ gnu/packages/gettext.scm:29:13: gettext would be upgraded from 0.18.1.1 to 0.18. gnu/packages/glib.scm:77:12: glib would be upgraded from 2.34.3 to 2.37.0 @end example -It does so by browsing the FTP directory of each package and determining -the highest version number of the source tarballs therein. The command +Alternately, one can specify packages to consider, in which case a +warning is emitted for packages that lack an updater: + +@example +$ guix refresh coreutils guile guile-ssh +gnu/packages/ssh.scm:205:2: warning: no updater for guile-ssh +gnu/packages/guile.scm:136:12: guile would be upgraded from 2.0.12 to 2.0.13 +@end example + +@command{guix refresh} browses the upstream repository of each package and determines +the highest version number of the releases therein. The command knows how to update specific types of packages: GNU packages, ELPA -packages, etc.---see the documentation for @option{--type} below. The +packages, etc.---see the documentation for @option{--type} below. There are many packages, though, for which it lacks a method to determine whether a new upstream release is available. However, the mechanism is extensible, so feel free to get in touch with us to add a new method! @@ -5293,7 +5302,7 @@ usually run from a checkout of the Guix source tree (@pxref{Running Guix Before It Is Installed}): @example -$ ./pre-inst-env guix refresh -s non-core +$ ./pre-inst-env guix refresh -s non-core -u @end example @xref{Defining Packages}, for more information on package definitions. @@ -5359,7 +5368,7 @@ In addition, @command{guix refresh} can be passed one or more package names, as in this example: @example -$ ./pre-inst-env guix refresh -u emacs idutils gcc-4.8.4 +$ ./pre-inst-env guix refresh -u emacs idutils gcc@@4.8 @end example @noindent diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index b81c69f9fe..ed28ed5fcb 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -208,7 +208,7 @@ (define %updaters ((guix import gem) => %gem-updater) ((guix import github) => %github-updater))) -(define (lookup-updater name) +(define (lookup-updater-by-name name) "Return the updater called NAME." (or (find (lambda (updater) (eq? name (upstream-updater-name updater))) @@ -225,31 +225,60 @@ (define (list-updaters-and-exit) %updaters) (exit 0)) +(define (warn-no-updater package) + (format (current-error-port) + (_ "~a: warning: no updater for ~a~%") + (location->string (package-location package)) + (package-name package))) + (define* (update-package store package updaters - #:key (key-download 'interactive)) + #:key (key-download 'interactive) warn?) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed -values: 'interactive' (default), 'always', and 'never'." - (let-values (((version tarball) - (package-update store package updaters - #:key-download key-download)) - ((loc) - (or (package-field-location package 'version) - (package-location package)))) - (when version - (if (and=> tarball file-exists?) - (begin - (format (current-error-port) - (_ "~a: ~a: updating from version ~a to version ~a...~%") - (location->string loc) - (package-name package) - (package-version package) version) - (let ((hash (call-with-input-file tarball - port-sha256))) - (update-package-source package version hash))) - (warning (_ "~a: version ~a could not be \ +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 tarball) + (package-update store package updaters + #:key-download key-download)) + ((loc) + (or (package-field-location package 'version) + (package-location package)))) + (when version + (if (and=> tarball file-exists?) + (begin + (format (current-error-port) + (_ "~a: ~a: updating from version ~a to version ~a...~%") + (location->string loc) + (package-name package) + (package-version package) version) + (let ((hash (call-with-input-file tarball + port-sha256))) + (update-package-source package version hash))) + (warning (_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") - (package-name package) version))))) + (package-name package) version)))) + (when warn? + (warn-no-updater package)))) + +(define* (check-for-package-update package #:key warn?) + "Check whether an update is available for PACKAGE and print a message. When +WARN? is true and no updater exists for PACKAGE, print a warning." + (match (package-latest-release package %updaters) + ((? upstream-source? source) + (when (version>? (upstream-source-version source) + (package-version package)) + (let ((loc (or (package-field-location package 'version) + (package-location package)))) + (format (current-error-port) + (_ "~a: ~a would be upgraded from ~a to ~a~%") + (location->string loc) + (package-name package) (package-version package) + (upstream-source-version source))))) + (#f + (when warn? + (warn-no-updater package))))) + ;;; @@ -312,7 +341,7 @@ (define (options->updaters opts) ;; Return the list of updaters to use. (match (filter-map (match-lambda (('updaters . names) - (map lookup-updater names)) + (map lookup-updater-by-name names)) (_ #f)) opts) (() @@ -360,6 +389,12 @@ (define core-package? (updaters (options->updaters opts)) (list-dependent? (assoc-ref opts 'list-dependent?)) (key-download (assoc-ref opts 'key-download)) + + ;; Warn about missing updaters when a package is explicitly given on + ;; the command line. + (warn? (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression))) + (packages (match (filter-map (match-lambda (('argument . spec) @@ -397,22 +432,13 @@ (define core-package? (%gpg-command)))) (for-each (cut update-package store <> updaters - #:key-download key-download) + #:key-download key-download + #:warn? warn?) packages) (with-monad %store-monad (return #t)))) (else - (for-each (lambda (package) - (match (package-update-path package updaters) - ((? upstream-source? source) - (let ((loc (or (package-field-location package 'version) - (package-location package)))) - (format (current-error-port) - (_ "~a: ~a would be upgraded from ~a to ~a~%") - (location->string loc) - (package-name package) (package-version package) - (upstream-source-version source)))) - (#f #f))) + (for-each (cut check-for-package-update <> #:warn? warn?) packages) (with-monad %store-monad (return #t))))))))) diff --git a/guix/upstream.scm b/guix/upstream.scm index 18157376d2..08992dc19e 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -49,8 +49,11 @@ (define-module (guix upstream) upstream-updater-predicate upstream-updater-latest + lookup-updater + download-tarball - package-update-path + package-latest-release + package-latest-release* package-update update-package-source)) @@ -127,17 +130,24 @@ (define (lookup-updater package updaters) (and (pred package) latest))) updaters)) -(define (package-update-path package updaters) +(define (package-latest-release package updaters) "Return an upstream source to update PACKAGE, a object, or #f if -no update is needed or known." +none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure +that the returned source is newer than the current one." (match (lookup-updater package updaters) ((? procedure? latest-release) - (match (latest-release package) - ((and source ($ name version)) - (and (version>? version (package-version package)) - source)) - (_ #f))) - (#f #f))) + (latest-release package)) + (_ #f))) + +(define (package-latest-release* package updaters) + "Like 'package-latest-release', but ensure that the return source is newer +than that of PACKAGE." + (match (package-latest-release package updaters) + ((and source ($ name version)) + (and (version>? version (package-version package)) + source)) + (_ + #f))) (define* (download-tarball store url signature-url #:key (key-download 'interactive)) @@ -179,7 +189,7 @@ (define* (package-update store package updaters PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'always', 'never', and 'interactive' (default)." - (match (package-update-path package updaters) + (match (package-latest-release* package updaters) (($ _ version urls signature-urls) (let*-values (((name) (package-name package)) -- cgit v1.2.3