[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
06/06: offload: Do not abort when a machine is unreachable.
From: |
Ludovic Courtès |
Subject: |
06/06: offload: Do not abort when a machine is unreachable. |
Date: |
Thu, 1 Dec 2016 22:35:32 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit 463fb7d0c86fb9957c527272e6cec5ee23585366
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 1 23:21:15 2016 +0100
offload: Do not abort when a machine is unreachable.
* guix/scripts/offload.scm (machine-load): Wrap 'open-ssh-session' call
in 'false-if-exception'; return +inf.0 if it returns #f.
---
guix/scripts/offload.scm | 39 +++++++++++++++++++++------------------
1 file changed, 21 insertions(+), 18 deletions(-)
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 0498364..237a963 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -493,27 +493,30 @@ be read."
(define (machine-load machine)
"Return the load of MACHINE, divided by the number of parallel builds
-allowed on MACHINE."
+allowed on MACHINE. Return +∞ if MACHINE is unreachable."
;; 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
+ (match (false-if-exception (open-ssh-session machine))
+ ((? session? session)
+ (let* ((pipe (open-remote-pipe* session OPEN_READ
"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
- (match (string-tokenize line)
- ((one five fifteen . _)
- (let* ((raw (string->number five))
- (jobs (build-machine-parallel-builds machine))
- (normalized (/ raw jobs)))
- (format (current-error-port) "load on machine '~a' is ~s\
+ (line (read-line pipe)))
+ (close-port pipe)
+
+ (if (eof-object? line)
+ +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
+ (match (string-tokenize line)
+ ((one five fifteen . _)
+ (let* ((raw (string->number five))
+ (jobs (build-machine-parallel-builds machine))
+ (normalized (/ raw jobs)))
+ (format (current-error-port) "load on machine '~a' is ~s\
(normalized: ~s)~%"
- (build-machine-name machine) raw normalized)
- normalized))
- (_
- +inf.0))))) ;something's fishy about MACHINE, so avoid it
+ (build-machine-name machine) raw normalized)
+ normalized))
+ (_
+ +inf.0))))) ;something's fishy about MACHINE, so avoid it
+ (_
+ +inf.0))) ;failed to connect to MACHINE, so avoid it
(define (machine-lock-file machine hint)
"Return the name of MACHINE's lock file for HINT."
- branch master updated (4b67098 -> 463fb7d), Ludovic Courtès, 2016/12/01
- 01/06: offload: Remove redundant call to 'topologically-sorted' in 'send-file'., Ludovic Courtès, 2016/12/01
- 03/06: daemon: Buffer data sent to clients by the 'export-path' RPC., Ludovic Courtès, 2016/12/01
- 05/06: offload: Gracefully report connection failures., Ludovic Courtès, 2016/12/01
- 02/06: offload: Warn about the lack of zlib support., Ludovic Courtès, 2016/12/01
- 04/06: store: Increase buffering for the '%stderr-write' upcall., Ludovic Courtès, 2016/12/01
- 06/06: offload: Do not abort when a machine is unreachable.,
Ludovic Courtès <=