From fc61b641c28db1fc70da798fb6dcedb853b1ad1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 5 Feb 2015 22:16:59 +0100 Subject: [PATCH] offload: Warn about SSH client issues. Suggested by Ricardo Wurmus . * guix/scripts/offload.scm (remote-pipe): Remove unneeded 'catch'. (machine-load): Check the exit value upon (close-pipe pipe). Call 'warning' when it is non-zero. --- guix/scripts/offload.scm | 41 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index be233d96be..e494500d56 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -191,25 +191,19 @@ (define (shell-quote str) (lambda () (write str)))) - (catch 'system-error - (lambda () - ;; 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)) + ;; 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) + ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. + "-i" (build-machine-private-key machine) - (build-machine-name machine) - (if quote? - (map shell-quote command) - command)))) - (lambda args - (warning (_ "failed to execute '~a': ~a~%") - %lshg-command (strerror (system-error-errno args))) - #f))) + (build-machine-name machine) + (if quote? + (map shell-quote command) + command)))) ;;; @@ -533,9 +527,14 @@ (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))) - (close-pipe pipe) + (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))) + (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded (match (string-tokenize line)