;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix i18n)
#:use-module (guix modules)
#:use-module (guix monads)
+ #:use-module (guix pki)
#:use-module (guix records)
#:use-module (guix remote)
#:use-module (guix scripts system reconfigure)
#:use-module (guix ssh)
#:use-module (guix store)
#:use-module (guix utils)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
+ #:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
machine-ssh-configuration-host-name
machine-ssh-configuration-build-locally?
+ machine-ssh-configuration-authorize?
machine-ssh-configuration-port
machine-ssh-configuration-user
+ machine-ssh-configuration-host-key
machine-ssh-configuration-session))
;;; Commentary:
(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
make-machine-ssh-configuration
machine-ssh-configuration?
- this-machine-ssh-configuration
- (host-name machine-ssh-configuration-host-name) ; string
- (system machine-ssh-configuration-system) ; string
- (build-locally? machine-ssh-configuration-build-locally?
+ (host-name machine-ssh-configuration-host-name) ; string
+ (system machine-ssh-configuration-system) ; string
+ (build-locally? machine-ssh-configuration-build-locally? ; boolean
(default #t))
- (port machine-ssh-configuration-port ; integer
+ (authorize? machine-ssh-configuration-authorize? ; boolean
+ (default #t))
+ (port machine-ssh-configuration-port ; integer
(default 22))
- (user machine-ssh-configuration-user ; string
+ (user machine-ssh-configuration-user ; string
(default "root"))
- (identity machine-ssh-configuration-identity ; path to a private key
+ (identity machine-ssh-configuration-identity ; path to a private key
+ (default #f))
+ (session machine-ssh-configuration-session ; session
(default #f))
- (session machine-ssh-configuration-session ; session
+ (host-key machine-ssh-configuration-host-key ; #f | string
(default #f)))
(define (machine-ssh-session machine)
(let ((host-name (machine-ssh-configuration-host-name config))
(user (machine-ssh-configuration-user config))
(port (machine-ssh-configuration-port config))
- (identity (machine-ssh-configuration-identity config)))
+ (identity (machine-ssh-configuration-identity config))
+ (host-key (machine-ssh-configuration-host-key config)))
+ (unless host-key
+ (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
+is deprecated~%")))
(open-ssh-session host-name
#:user user
#:port port
- #:identity identity)))))
+ #:identity identity
+ #:host-key host-key)))))
\f
;;;
#:build-locally?
(machine-ssh-configuration-build-locally? config)
#:system
- (machine-ssh-configuration-system config))))
+ (machine-ssh-configuration-system config)
+ #:become-command
+ (machine-become-command machine))))
\f
;;;
;;; 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)
- "Raise a '&message' error condition if any of the file-systems specified in
-MACHINE's 'system' declaration do not exist on the machine."
+ "Return a list of <remote-assertion> that raise a '&message' error condition
+if any of the file-systems specified in MACHINE's 'system' declaration do not
+exist on the machine."
(define file-systems
(filter (lambda (fs)
(and (file-system-mount? fs)
(operating-system-file-systems (machine-operating-system machine))))
(define (check-literal-file-system fs)
- (define remote-exp
- #~(catch 'system-error
- (lambda ()
- (stat #$(file-system-device fs))
- #t)
- (lambda args
- (system-error-errno args))))
-
- (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
+ (remote-let ((errno #~(catch 'system-error
+ (lambda ()
+ (stat #$(file-system-device fs))
+ #t)
+ (lambda args
+ (system-error-errno args)))))
(when (number? errno)
(raise (condition
(&message
(message (format #f (G_ "device '~a' not found: ~a")
(file-system-device fs)
- (strerror errno)))))))
- (return #t)))
+ (strerror errno)))))))))
(define (check-labeled-file-system fs)
(define remote-exp
- (with-imported-modules '((gnu build file-systems))
+ (with-imported-modules (source-module-closure
+ '((gnu build file-systems)))
#~(begin
(use-modules (gnu build file-systems))
(find-partition-by-label #$(file-system-label->string
(file-system-device fs))))))
- (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+ (remote-let ((result remote-exp))
(unless result
(raise (condition
(&message
(message (format #f (G_ "no file system with label '~a'")
(file-system-label->string
- (file-system-device fs))))))))
- (return #t)))
+ (file-system-device fs))))))))))
(define (check-uuid-file-system fs)
(define remote-exp
(use-modules (gnu build file-systems)
(gnu system uuid))
- (define uuid
- (string->uuid #$(uuid->string (file-system-device fs))))
+ (let ((uuid (uuid #$(uuid->string (file-system-device fs))
+ '#$(uuid-type (file-system-device fs)))))
+ (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
(raise (condition
(&message
(message (format #f (G_ "no file system with UUID '~a'")
- (uuid->string (file-system-device fs))))))))
- (return #t)))
-
- (mbegin %store-monad
- (mapm %store-monad check-literal-file-system
- (filter (lambda (fs)
- (string? (file-system-device fs)))
- file-systems))
- (mapm %store-monad check-labeled-file-system
- (filter (lambda (fs)
- (file-system-label? (file-system-device fs)))
- file-systems))
- (mapm %store-monad check-uuid-file-system
- (filter (lambda (fs)
- (uuid? (file-system-device fs)))
- file-systems))))
+ (uuid->string (file-system-device fs))))))))))
+
+ (append (map check-literal-file-system
+ (filter (lambda (fs)
+ (string? (file-system-device fs)))
+ file-systems))
+ (map check-labeled-file-system
+ (filter (lambda (fs)
+ (file-system-label? (file-system-device fs)))
+ file-systems))
+ (map check-uuid-file-system
+ (filter (lambda (fs)
+ (uuid? (file-system-device fs)))
+ file-systems))))
(define (machine-check-initrd-modules machine)
- "Raise a '&message' error condition if any of the modules needed by
-'needed-for-boot' file systems in MACHINE are not available in the initrd."
+ "Return a list of <remote-assertion> that raise a '&message' error condition
+if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
+not available in the initrd."
(define file-systems
(filter file-system-needed-for-boot?
(operating-system-file-systems (machine-operating-system machine))))
#$(uuid->string device))))
((file-system-label? device)
#~(find-partition-by-label
- (file-system-label->string #$device)))))
+ #$(file-system-label->string device)))))
(missing-modules dev '#$(operating-system-initrd-modules
(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)))
- (for-each (match-lambda
- ((fs missing)
- (unless (null? missing)
- (raise (condition
- (&message
- (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
- (file-system-device fs)
- missing))))))))
- device)
- (return #t)))
+
+ (remote-let ((missing remote-exp))
+ (unless (null? missing)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "missing modules for ~a:~{ ~a~}~%")
+ (file-system-device fs)
+ missing))))))))
+
+ (map missing-modules file-systems))
(define (machine-check-building-for-appropriate-system machine)
"Raise a '&message' error condition if MACHINE is configured to be built
(not (string= system (machine-ssh-configuration-system config))))
(raise (condition
(&message
- (message (format #f (G_ "incorrect target system \
-('~a' was given, while the system reports that it is '~a')~%")
+ (message (format #f (G_ "incorrect target system\
+ ('~a' was given, while the system reports that it is '~a')~%")
(machine-ssh-configuration-system config)
- system)))))))
- (with-monad %store-monad (return #t)))
+ system))))))))
(define (check-deployment-sanity machine)
"Raise a '&message' error condition if it is clear that deploying MACHINE's
'system' declaration would fail."
- ;; Order is important here -- an incorrect value for 'system' will cause
- ;; invocations of 'remote-eval' to fail.
- (mbegin %store-monad
- (machine-check-building-for-appropriate-system machine)
- (machine-check-file-system-availability machine)
- (machine-check-initrd-modules machine)))
+ (define assertions
+ (append (machine-check-file-system-availability machine)
+ (machine-check-initrd-modules machine)))
+
+ (define aggregate-exp
+ ;; 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)))
\f
;;;
"Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
(maybe-raise-unsupported-configuration-error machine)
+ (when (machine-ssh-configuration-authorize?
+ (machine-configuration machine))
+ (unless (file-exists? %public-key-file)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "no signing key '~a'. \
+have you run 'guix archive --generate-key?'")
+ %public-key-file))))))
+ (remote-authorize-signing-key (call-with-input-file %public-key-file
+ (lambda (port)
+ (string->canonical-sexp
+ (get-string-all port))))
+ (machine-ssh-session machine)
+ (machine-become-command machine)))
(mlet %store-monad ((_ (check-deployment-sanity machine))
(boot-parameters (machine-boot-parameters machine)))
(let* ((os (machine-operating-system machine))
HCoop / jackhill / guix / guix.git / blobdiff