me/guix
Archived
1
0
Fork 0
Code Activity

offload: Adjust 'test' and 'status' to the latest changes.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2018-12-25 17:03:37 +01:00
parent 522d1b87bc
commit 10b2834f82
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 45 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

88
guix/scripts/offload.scm
View file

@ -624,35 +624,30 @@ If TIMEOUT is #f, simply evaluate EXP..."
name (node-guile-version node))))) name (node-guile-version node)))))
(define (assert-node-has-guix node name) (define (assert-node-has-guix node name)
"Bail out if NODE lacks the (guix) module, or if its daemon is not running." "Bail out if NODE if #f or if we fail to use the (guix) module, or if its
(catch 'node-repl-error daemon is not running."
(lambda () (unless (inferior? node)
(match (inferior-eval '(begin (leave (G_ "failed to run 'guix repl' on '~a'~%") name))
(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 (match (inferior-eval '(begin
(lambda () (use-modules (guix))
(match (inferior-eval '(begin (and add-text-to-store 'alright))
(use-modules (guix)) node)
(with-store store ('alright #t)
(add-text-to-store store "test" (_ (report-module-error name)))
"Hello, build machine!")))
node) (match (inferior-eval '(begin
((? string? str) (use-modules (guix))
(info (G_ "Guix is usable on '~a' (test returned ~s)~%") (with-store store
name str)) (add-text-to-store store "test"
(x "Hello, build machine!")))
(leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") node)
name x)))) ((? string? str)
(lambda (key . args) (info (G_ "Guix is usable on '~a' (test returned ~s)~%")
(leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") name str))
name args)))) (x
(leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%")
name x))))
(define %random-state (define %random-state
(delay (delay
@ -706,8 +701,8 @@ machine."
(sockets (map build-machine-daemon-socket machines)) (sockets (map build-machine-daemon-socket machines))
(sessions (map open-ssh-session machines)) (sessions (map open-ssh-session machines))
(nodes (map remote-inferior sessions))) (nodes (map remote-inferior sessions)))
(for-each assert-node-repl nodes names)
(for-each assert-node-has-guix 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-import sessions nodes names sockets)
(for-each assert-node-can-export sessions nodes names sockets) (for-each assert-node-can-export sessions nodes names sockets)
(for-each close-inferior nodes) (for-each close-inferior nodes)
@ -727,21 +722,28 @@ machine."
(info (G_ "getting status of ~a build machines defined in '~a'...~%") (info (G_ "getting status of ~a build machines defined in '~a'...~%")
(length machines) machine-file) (length machines) machine-file)
(for-each (lambda (machine) (for-each (lambda (machine)
(let* ((session (open-ssh-session machine)) (define session
(inferior (remote-inferior session)) (open-ssh-session machine))
(uts (inferior-eval '(uname) inferior))
(load (node-load inferior)) (match (remote-inferior session)
(free (node-free-disk-space inferior))) (#f
(close-inferior inferior) (warning (G_ "failed to run 'guix repl' on machine '~a'~%")
(disconnect! session) (build-machine-name machine)))
(format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ ((? 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~%" host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%"
(build-machine-name machine) (build-machine-name machine)
(utsname:sysname uts) (utsname:release uts) (utsname:sysname uts) (utsname:release uts)
(utsname:machine uts) (utsname:machine uts)
(utsname:nodename uts) (utsname:nodename uts)
(normalized-load machine load) (normalized-load machine load)
(/ free (expt 2 20) 1.)))) (/ free (expt 2 20) 1.)))))
(disconnect! session))
machines))) machines)))