diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/offload.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 16 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 20 |
3 files changed, 45 insertions, 31 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 925325ef5f..578b3b9888 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -25,7 +25,7 @@ #:autoload (ssh auth) (userauth-public-key!) #:autoload (ssh session) (make-session connect! get-error - disconnect! session-set!) + disconnect! session-set! session-get) #:autoload (ssh version) (zlib-support?) #:use-module (guix config) #:use-module (guix records) @@ -34,7 +34,8 @@ send-files retrieve-files retrieve-files* remote-inferior report-guile-error) #:use-module (guix store) - #:autoload (guix inferior) (inferior-eval close-inferior inferior?) + #:autoload (guix inferior) (inferior-eval close-inferior + inferior? inferior-protocol-error?) #:autoload (guix derivations) (read-derivation-from-file derivation-file-name build-derivations) @@ -111,7 +112,7 @@ ;; A #f value tells the offload scheduler to disregard the load of the build ;; machine when selecting the best offload machine. (overload-threshold build-machine-overload-threshold ; inexact real between - (default 0.6)) ; 0.0 and 1.0 | #f + (default 0.8)) ; 0.0 and 1.0 | #f (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -473,6 +474,15 @@ logical cores available, to give a rough estimation of CPU usage. Return (vector-set! vec j (vector-ref vec (- i 1))) (loop (cons val result) (- i 1)))))))) +(define (remote-inferior* session) + "Like 'remote-inferior', but upon error return #f." + (or (guard (c ((inferior-protocol-error? c) #f)) + (remote-inferior session)) + (begin + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (session-get session 'host)) + #f))) + (define (choose-build-machine machines) "Return two values: the best machine among MACHINES and its build slot (which must later be released with 'release-build-slot'), or #f and #f." @@ -511,7 +521,7 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best %short-timeout))) - (node (and session (remote-inferior session))) + (node (and session (remote-inferior* session))) (load (and node (node-load node))) (threshold (build-machine-overload-threshold best)) (space (and node (node-free-disk-space node)))) @@ -708,6 +718,11 @@ machine." (and (string=? (build-machine-name m1) (build-machine-name m2)) (= (build-machine-port m1) (build-machine-port m2)))) + (define (if-true proc) + (lambda args + (when (every ->bool args) + (apply proc args)))) + ;; A given build machine may appear several times (e.g., once for ;; "x86_64-linux" and a second time for "i686-linux"); test them only once. (let ((machines (filter pred @@ -718,12 +733,12 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map (cut open-ssh-session <> %short-timeout) machines)) - (nodes (map remote-inferior sessions))) - (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) + (nodes (map remote-inferior* sessions))) + (for-each (if-true assert-node-has-guix) nodes names) + (for-each (if-true assert-node-repl) nodes names) + (for-each (if-true assert-node-can-import) sessions nodes names sockets) + (for-each (if-true assert-node-can-export) sessions nodes names sockets) + (for-each (if-true close-inferior) nodes) (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) @@ -743,10 +758,9 @@ machine." (define session (open-ssh-session machine %short-timeout)) - (match (remote-inferior session) + (match (remote-inferior* session) (#f - (warning (G_ "failed to run 'guix repl' on machine '~a'~%") - (build-machine-name machine))) + #f) ((? inferior? inferior) (let ((now (car (gettimeofday)))) (match (inferior-eval '(list (uname) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index c0b9ea1a28..fa7175fb16 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -335,13 +335,15 @@ PACKAGE." (define* (format-whole-file file #:rest rest) "Reformat all of FILE." - (let ((lst (call-with-input-file file read-with-comments/sequence))) - (with-atomic-file-output file - (lambda (port) - (apply pretty-print-with-comments/splice port lst - #:format-comment canonicalize-comment - #:format-vertical-space canonicalize-vertical-space - rest))))) + (with-fluids ((%default-port-encoding "UTF-8")) + (let ((lst (call-with-input-file file read-with-comments/sequence + #:guess-encoding #t))) + (with-atomic-file-output file + (lambda (port) + (apply pretty-print-with-comments/splice port lst + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space + rest)))))) ;;; diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index afd410d4bc..544aacfef4 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -40,9 +40,9 @@ #:use-module (guix diagnostics) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module ((guix config) #:select (%guix-package-name)) #:export (switch-system-program switch-to-system @@ -184,8 +184,8 @@ services as defined by OS." #:target-type shepherd-root-service-type)))) (mlet* %store-monad ((live-services (running-services eval))) - (let*-values (((to-unload to-restart) - (shepherd-service-upgrade live-services target-services))) + (let ((to-unload to-restart + (shepherd-service-upgrade live-services target-services))) (let* ((to-unload (map live-service-canonical-name to-unload)) (to-restart (map shepherd-service-canonical-name to-restart)) (running (map live-service-canonical-name @@ -347,14 +347,12 @@ to commits of channels in NEW." (channel-name old))) new))) (and new - (let-values (((checkout commit relation) - (update-cached-checkout - (channel-url new) - #:ref - `(commit . ,(channel-commit new)) - #:starting-commit - (channel-commit old) - #:check-out? #f))) + (let ((checkout commit relation + (update-cached-checkout + (channel-url new) + #:ref `(commit . ,(channel-commit new)) + #:starting-commit (channel-commit old) + #:check-out? #f))) (list new (channel-commit old) (channel-commit new) relation))))) |