me
/
guix
Archived
1
0
Fork 0
Code

machine: ssh: Make sanity checks in a single round trip. 

* gnu/machine/ssh.scm (<remote-assertion>): New record type.
(remote-let): New macro.
(machine-check-file-system-availability): Rewrite to use 'remote-let'
instead of 'mlet' and 'machine-remote-eval'.
(machine-check-initrd-modules): Likewise.
(machine-check-building-for-appropriate-system): Make non-monadic.
(check-deployment-sanity): Rewrite to gather all the assertions as a
single gexp and pass it to 'machine-remote-eval'.
master
Ludovic Courtès 2020-03-20 12:08:10 +01:00
parent 8f53d73493
commit ea6e2299b4
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 81 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

138
gnu/machine/ssh.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -39,6 +40,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
@ -142,9 +144,24 @@ an environment type of 'managed-host."
;;; Safety checks. ;;; Safety checks.
;;; ;;;
;; Assertion to be executed remotely. This abstraction exists to allow us to
;; gather a list of expressions to be evaluated and eventually evaluate them
;; all at once instead of one by one. (This is pretty much a monad.)
(define-record-type <remote-assertion>
(remote-assertion exp proc)
remote-assertion?
(exp remote-assertion-expression)
(proc remote-assertion-procedure))
(define-syntax-rule (remote-let ((var exp)) body ...)
"Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
a gexp, remotely, and evaluate BODY in that context."
(remote-assertion exp (lambda (var) body ...)))
(define (machine-check-file-system-availability machine) (define (machine-check-file-system-availability machine)
"Raise a '&message' error condition if any of the file-systems specified in "Return a list of <remote-assertion> that raise a '&message' error condition
MACHINE's 'system' declaration do not exist on the machine." if any of the file-systems specified in MACHINE's 'system' declaration do not
exist on the machine."
(define file-systems (define file-systems
(filter (lambda (fs) (filter (lambda (fs)
(and (file-system-mount? fs) (and (file-system-mount? fs)
@ -154,22 +171,18 @@ MACHINE's 'system' declaration do not exist on the machine."
(operating-system-file-systems (machine-operating-system machine)))) (operating-system-file-systems (machine-operating-system machine))))
(define (check-literal-file-system fs) (define (check-literal-file-system fs)
(define remote-exp (remote-let ((errno #~(catch 'system-error
#~(catch 'system-error (lambda ()
(lambda () (stat #$(file-system-device fs))
(stat #$(file-system-device fs)) #t)
#t) (lambda args
(lambda args (system-error-errno args)))))
(system-error-errno args))))
(mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
(when (number? errno) (when (number? errno)
(raise (condition (raise (condition
(&message (&message
(message (format #f (G_ "device '~a' not found: ~a") (message (format #f (G_ "device '~a' not found: ~a")
(file-system-device fs) (file-system-device fs)
(strerror errno))))))) (strerror errno)))))))))
(return #t)))
(define (check-labeled-file-system fs) (define (check-labeled-file-system fs)
(define remote-exp (define remote-exp
@ -180,14 +193,13 @@ MACHINE's 'system' declaration do not exist on the machine."
(find-partition-by-label #$(file-system-label->string (find-partition-by-label #$(file-system-label->string
(file-system-device fs)))))) (file-system-device fs))))))
(mlet %store-monad ((result (machine-remote-eval machine remote-exp))) (remote-let ((result remote-exp))
(unless result (unless result
(raise (condition (raise (condition
(&message (&message
(message (format #f (G_ "no file system with label '~a'") (message (format #f (G_ "no file system with label '~a'")
(file-system-label->string (file-system-label->string
(file-system-device fs)))))))) (file-system-device fs))))))))))
(return #t)))
(define (check-uuid-file-system fs) (define (check-uuid-file-system fs)
(define remote-exp (define remote-exp
@ -203,31 +215,30 @@ MACHINE's 'system' declaration do not exist on the machine."
(find-partition-by-uuid uuid)))) (find-partition-by-uuid uuid))))
(mlet %store-monad ((result (machine-remote-eval machine remote-exp))) (remote-let ((result remote-exp))
(unless result (unless result
(raise (condition (raise (condition
(&message (&message
(message (format #f (G_ "no file system with UUID '~a'") (message (format #f (G_ "no file system with UUID '~a'")
(uuid->string (file-system-device fs)))))))) (uuid->string (file-system-device fs))))))))))
(return #t)))
(mbegin %store-monad (append (map check-literal-file-system
(mapm %store-monad check-literal-file-system (filter (lambda (fs)
(filter (lambda (fs) (string? (file-system-device fs)))
(string? (file-system-device fs))) file-systems))
file-systems)) (map check-labeled-file-system
(mapm %store-monad check-labeled-file-system (filter (lambda (fs)
(filter (lambda (fs) (file-system-label? (file-system-device fs)))
(file-system-label? (file-system-device fs))) file-systems))
file-systems)) (map check-uuid-file-system
(mapm %store-monad check-uuid-file-system (filter (lambda (fs)
(filter (lambda (fs) (uuid? (file-system-device fs)))
(uuid? (file-system-device fs))) file-systems))))
file-systems))))
(define (machine-check-initrd-modules machine) (define (machine-check-initrd-modules machine)
"Raise a '&message' error condition if any of the modules needed by "Return a list of <remote-assertion> that raise a '&message' error condition
'needed-for-boot' file systems in MACHINE are not available in the initrd." if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
not available in the initrd."
(define file-systems (define file-systems
(filter file-system-needed-for-boot? (filter file-system-needed-for-boot?
(operating-system-file-systems (machine-operating-system machine)))) (operating-system-file-systems (machine-operating-system machine))))
@ -255,20 +266,16 @@ MACHINE's 'system' declaration do not exist on the machine."
(missing-modules dev '#$(operating-system-initrd-modules (missing-modules dev '#$(operating-system-initrd-modules
(machine-operating-system machine))))))) (machine-operating-system machine)))))))
(mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
(return (list fs missing))))
(mlet %store-monad ((device (mapm %store-monad missing-modules file-systems))) (remote-let ((missing remote-exp))
(for-each (match-lambda (unless (null? missing)
((fs missing) (raise (condition
(unless (null? missing) (&message
(raise (condition (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
(&message (file-system-device fs)
(message (format #f (G_ "~a missing modules ~{ ~a~}~%") missing))))))))
(file-system-device fs)
missing)))))))) (map missing-modules file-systems))
device)
(return #t)))
(define (machine-check-building-for-appropriate-system machine) (define (machine-check-building-for-appropriate-system machine)
"Raise a '&message' error condition if MACHINE is configured to be built "Raise a '&message' error condition if MACHINE is configured to be built
@ -280,21 +287,38 @@ by MACHINE."
(not (string= system (machine-ssh-configuration-system config)))) (not (string= system (machine-ssh-configuration-system config))))
(raise (condition (raise (condition
(&message (&message
(message (format #f (G_ "incorrect target system \ (message (format #f (G_ "incorrect target system\
('~a' was given, while the system reports that it is '~a')~%") ('~a' was given, while the system reports that it is '~a')~%")
(machine-ssh-configuration-system config) (machine-ssh-configuration-system config)
system))))))) system))))))))
(with-monad %store-monad (return #t)))
(define (check-deployment-sanity machine) (define (check-deployment-sanity machine)
"Raise a '&message' error condition if it is clear that deploying MACHINE's "Raise a '&message' error condition if it is clear that deploying MACHINE's
'system' declaration would fail." 'system' declaration would fail."
;; Order is important here -- an incorrect value for 'system' will cause (define assertions
;; invocations of 'remote-eval' to fail. (append (machine-check-file-system-availability machine)
(mbegin %store-monad (machine-check-initrd-modules machine)))
(machine-check-building-for-appropriate-system machine)
(machine-check-file-system-availability machine) (define aggregate-exp
(machine-check-initrd-modules machine))) ;; Gather all the expressions so that a single round-trip is enough to
;; evaluate all the ASSERTIONS remotely.
#~(map (lambda (file)
(false-if-exception (primitive-load file)))
'#$(map (lambda (assertion)
(scheme-file "remote-assertion.scm"
(remote-assertion-expression assertion)))
assertions)))
;; First check MACHINE's system type--an incorrect value for 'system' would
;; cause subsequent invocations of 'remote-eval' to fail.
(machine-check-building-for-appropriate-system machine)
(mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
(for-each (lambda (proc value)
(proc value))
(map remote-assertion-procedure assertions)
values)
(return #t)))
;;; ;;;