aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-12-25 17:03:37 +0100
committerLudovic Courtès <ludo@gnu.org>2018-12-25 17:13:43 +0100
commit10b2834f82b7502dc2dc733d39d97f9ff2d07564 (patch)
tree72ca441e00380d21ffb72c8e31233a822ed85f2a
parent522d1b87bc88dd459ade51b1ee0545937da8d3b5 (diff)
downloadguix-10b2834f82b7502dc2dc733d39d97f9ff2d07564.tar
guix-10b2834f82b7502dc2dc733d39d97f9ff2d07564.tar.gz
offload: Adjust 'test' and 'status' to the latest changes.
This is a followup to ed7b44370f71126087eb953f36aad8dc4c44109f; following that commit, 'guix offload test' and 'guix offload status' would abort with a backtrace instead of clearly diagnosing a missing 'guix' command on the build machine. * guix/scripts/offload.scm (assert-node-has-guix): Call 'leave' when NODE is not an inferior. Remove 'catch' blocks for 'node-repl-error'. (check-machine-availability): Invoke 'assert-node-has-guix' first. (check-machine-status): Print a warning when 'remote-inferior' returns #f.
-rw-r--r--guix/scripts/offload.scm90
1 files changed, 46 insertions, 44 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index b472d202a9..dcdccc80e0 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -624,35 +624,30 @@ If TIMEOUT is #f, simply evaluate EXP..."
name (node-guile-version node)))))
(define (assert-node-has-guix node name)
- "Bail out if NODE lacks the (guix) module, or if its daemon is not running."
- (catch 'node-repl-error
- (lambda ()
- (match (inferior-eval '(begin
- (use-modules (guix))
- (and add-text-to-store 'alright))
- node)
- ('alright #t)
- (_ (report-module-error name))))
- (lambda (key . args)
- (report-module-error name)))
-
- (catch 'node-repl-error
- (lambda ()
- (match (inferior-eval '(begin
- (use-modules (guix))
- (with-store store
- (add-text-to-store store "test"
- "Hello, build machine!")))
- node)
- ((? string? str)
- (info (G_ "Guix is usable on '~a' (test returned ~s)~%")
- name str))
- (x
- (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%")
- name x))))
- (lambda (key . args)
- (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%")
- name args))))
+ "Bail out if NODE if #f or if we fail to use the (guix) module, or if its
+daemon is not running."
+ (unless (inferior? node)
+ (leave (G_ "failed to run 'guix repl' on '~a'~%") name))
+
+ (match (inferior-eval '(begin
+ (use-modules (guix))
+ (and add-text-to-store 'alright))
+ node)
+ ('alright #t)
+ (_ (report-module-error name)))
+
+ (match (inferior-eval '(begin
+ (use-modules (guix))
+ (with-store store
+ (add-text-to-store store "test"
+ "Hello, build machine!")))
+ node)
+ ((? string? str)
+ (info (G_ "Guix is usable on '~a' (test returned ~s)~%")
+ name str))
+ (x
+ (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%")
+ name x))))
(define %random-state
(delay
@@ -706,8 +701,8 @@ machine."
(sockets (map build-machine-daemon-socket machines))
(sessions (map open-ssh-session machines))
(nodes (map remote-inferior sessions)))
- (for-each assert-node-repl nodes names)
(for-each assert-node-has-guix nodes names)
+ (for-each assert-node-repl nodes names)
(for-each assert-node-can-import sessions nodes names sockets)
(for-each assert-node-can-export sessions nodes names sockets)
(for-each close-inferior nodes)
@@ -727,21 +722,28 @@ machine."
(info (G_ "getting status of ~a build machines defined in '~a'...~%")
(length machines) machine-file)
(for-each (lambda (machine)
- (let* ((session (open-ssh-session machine))
- (inferior (remote-inferior session))
- (uts (inferior-eval '(uname) inferior))
- (load (node-load inferior))
- (free (node-free-disk-space inferior)))
- (close-inferior inferior)
- (disconnect! session)
- (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\
+ (define session
+ (open-ssh-session machine))
+
+ (match (remote-inferior session)
+ (#f
+ (warning (G_ "failed to run 'guix repl' on machine '~a'~%")
+ (build-machine-name machine)))
+ ((? inferior? inferior)
+ (let ((uts (inferior-eval '(uname) inferior))
+ (load (node-load inferior))
+ (free (node-free-disk-space inferior)))
+ (close-inferior inferior)
+ (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\
host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%"
- (build-machine-name machine)
- (utsname:sysname uts) (utsname:release uts)
- (utsname:machine uts)
- (utsname:nodename uts)
- (normalized-load machine load)
- (/ free (expt 2 20) 1.))))
+ (build-machine-name machine)
+ (utsname:sysname uts) (utsname:release uts)
+ (utsname:machine uts)
+ (utsname:nodename uts)
+ (normalized-load machine load)
+ (/ free (expt 2 20) 1.)))))
+
+ (disconnect! session))
machines)))