[jackhill/guix/guix.git] / gnu / machine / ssh.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu machine ssh)
  #:use-module (gnu machine)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system uuid)
  #:use-module (guix diagnostics)
  #:use-module (guix gexp)
  #:use-module (guix i18n)
  #:use-module (guix modules)
  #:use-module (guix monads)
  #: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 (ice-9 match)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (managed-host-environment-type

            machine-ssh-configuration
            machine-ssh-configuration?
            machine-ssh-configuration

            machine-ssh-configuration-host-name
            machine-ssh-configuration-build-locally?
            machine-ssh-configuration-port
            machine-ssh-configuration-user
            machine-ssh-configuration-session))

;;; Commentary:
;;;
;;; This module implements remote evaluation and system deployment for
;;; machines that are accessible over SSH and have a known host-name. In the
;;; sense of the broader "machine" interface, we describe the environment for
;;; such machines as 'managed-host.
;;;
;;; Code:

\f
;;;
;;; Parameters for the SSH client.
;;;

(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?
                  (default #t))
  (port           machine-ssh-configuration-port       ; integer
                  (default 22))
  (user           machine-ssh-configuration-user       ; string
                  (default "root"))
  (identity       machine-ssh-configuration-identity   ; path to a private key
                  (default #f))
  (session        machine-ssh-configuration-session    ; session
                  (default #f)))

(define (machine-ssh-session machine)
  "Return the SSH session that was given in MACHINE's configuration, or create
one from the configuration's parameters if one was not provided."
  (maybe-raise-unsupported-configuration-error machine)
  (let ((config (machine-configuration machine)))
    (or (machine-ssh-configuration-session config)
        (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)))
          (open-ssh-session host-name
                            #:user user
                            #:port port
                            #:identity identity)))))

\f
;;;
;;; Remote evaluation.
;;;

(define (machine-become-command machine)
  "Return as a list of strings the program and arguments necessary to run a
shell command with escalated privileges for MACHINE's configuration."
  (if (string= "root" (machine-ssh-configuration-user
                       (machine-configuration machine)))
      '()
      '("/run/setuid-programs/sudo" "-n" "--")))

(define (managed-host-remote-eval machine exp)
  "Internal implementation of 'machine-remote-eval' for MACHINE instances with
an environment type of 'managed-host."
  (maybe-raise-unsupported-configuration-error machine)
  (let ((config (machine-configuration machine)))
    (remote-eval exp (machine-ssh-session machine)
                 #:build-locally?
                 (machine-ssh-configuration-build-locally? config)
                 #:system
                 (machine-ssh-configuration-system config))))

\f
;;;
;;; Safety checks.
;;;

(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."
  (define file-systems
    (filter (lambda (fs)
              (and (file-system-mount? fs)
                   (not (member (file-system-type fs)
                                %pseudo-file-system-types))
                   (not (memq 'bind-mount (file-system-flags 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)))
      (when (number? errno)
        (raise (condition
                (&message
                 (message (format #f (G_ "device '~a' not found: ~a")
                                  (file-system-device fs)
                                  (strerror errno)))))))
      (return #t)))

  (define (check-labeled-file-system fs)
    (define remote-exp
      (with-imported-modules '((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)))
      (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)))

  (define (check-uuid-file-system fs)
    (define remote-exp
      (with-imported-modules (source-module-closure
                              '((gnu build file-systems)
                                (gnu system uuid)))
        #~(begin
            (use-modules (gnu build file-systems)
                         (gnu system uuid))

            (define uuid
              (string->uuid #$(uuid->string (file-system-device fs))))

            (find-partition-by-uuid uuid))))

    (mlet %store-monad ((result (machine-remote-eval machine 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))))

(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."
  (define file-systems
    (filter file-system-needed-for-boot?
            (operating-system-file-systems (machine-operating-system machine))))

  (define (missing-modules fs)
    (define remote-exp
      (let ((device (file-system-device fs)))
        (with-imported-modules (source-module-closure
                                '((gnu build file-systems)
                                  (gnu build linux-modules)
                                  (gnu system uuid)))
          #~(begin
              (use-modules (gnu build file-systems)
                           (gnu build linux-modules)
                           (gnu system uuid))

              (define dev
                #$(cond ((string? device) device)
                        ((uuid? device) #~(find-partition-by-uuid
                                           (string->uuid
                                            #$(uuid->string device))))
                        ((file-system-label? device)
                         #~(find-partition-by-label
                            (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)))

(define (machine-check-building-for-appropriate-system machine)
  "Raise a '&message' error condition if MACHINE is configured to be built
locally and the 'system' field does not match the '%current-system' reported
by MACHINE."
  (let ((config (machine-configuration machine))
        (system (remote-system (machine-ssh-session machine))))
    (when (and (machine-ssh-configuration-build-locally? config)
               (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')~%")
                                (machine-ssh-configuration-system config)
                                system)))))))
  (with-monad %store-monad (return #t)))

(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)))

\f
;;;
;;; System deployment.
;;;

(define (machine-boot-parameters machine)
  "Monadic procedure returning a list of 'boot-parameters' for the generations
of MACHINE's system profile, ordered from most recent to oldest."
  (define bootable-kernel-arguments
    (@@ (gnu system) bootable-kernel-arguments))

  (define remote-exp
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((guix config)
                                                      (guix profiles)))
        #~(begin
            (use-modules (guix config)
                         (guix profiles)
                         (ice-9 textual-ports))

            (define %system-profile
              (string-append %state-directory "/profiles/system"))

            (define (read-file path)
              (call-with-input-file path
                (lambda (port)
                  (get-string-all port))))

            (map (lambda (generation)
                   (let* ((system-path (generation-file-name %system-profile
                                                             generation))
                          (boot-parameters-path (string-append system-path
                                                               "/parameters"))
                          (time (stat:mtime (lstat system-path))))
                     (list generation
                           system-path
                           time
                           (read-file boot-parameters-path))))
                 (reverse (generation-numbers %system-profile)))))))

  (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
    (return
     (map (lambda (generation)
            (match generation
              ((generation system-path time serialized-params)
               (let* ((params (call-with-input-string serialized-params
                                read-boot-parameters))
                      (root (boot-parameters-root-device params))
                      (label (boot-parameters-label params)))
                 (boot-parameters
                  (inherit params)
                  (label
                   (string-append label " (#"
                                  (number->string generation) ", "
                                  (let ((time (make-time time-utc 0 time)))
                                    (date->string (time-utc->date time)
                                                  "~Y-~m-~d ~H:~M"))
                                  ")"))
                  (kernel-arguments
                   (append (bootable-kernel-arguments system-path root)
                           (boot-parameters-kernel-arguments params))))))))
          generations))))

(define (deploy-managed-host machine)
  "Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
  (maybe-raise-unsupported-configuration-error machine)
  (mlet %store-monad ((_ (check-deployment-sanity machine))
                      (boot-parameters (machine-boot-parameters machine)))
    (let* ((os (machine-operating-system machine))
           (eval (cut machine-remote-eval machine <>))
           (menu-entries (map boot-parameters->menu-entry boot-parameters))
           (bootloader-configuration (operating-system-bootloader os))
           (bootcfg (operating-system-bootcfg os menu-entries)))
      (mbegin %store-monad
        (switch-to-system eval os)
        (upgrade-shepherd-services eval os)
        (install-bootloader eval bootloader-configuration bootcfg)))))

\f
;;;
;;; Environment type.
;;;

(define managed-host-environment-type
  (environment-type
   (machine-remote-eval managed-host-remote-eval)
   (deploy-machine      deploy-managed-host)
   (name                'managed-host-environment-type)
   (description         "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
connection to the host.")))

(define (maybe-raise-unsupported-configuration-error machine)
  "Raise an error if MACHINE's configuration is not an instance of
<machine-ssh-configuration>."
  (let ((config (machine-configuration machine))
        (environment (environment-type-name (machine-environment machine))))
    (unless (and config (machine-ssh-configuration? config))
      (raise (condition
              (&message
               (message (format #f (G_ "unsupported machine configuration '~a'
for environment of type '~a'")
                                config
                                environment))))))))
Commit	Line	Data
fa9edf09 JK	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (gnu machine ssh)
fa9edf09 JK	20	#:use-module (gnu machine)
fa9edf09 JK	21	#:autoload (gnu packages gnupg) (guile-gcrypt)
fa9edf09	22	#:use-module (gnu system)
fd3119db JK	23	#:use-module (gnu system file-systems)
	24	#:use-module (gnu system uuid)
	25	#:use-module (guix diagnostics)
fa9edf09 JK	26	#:use-module (guix gexp)
	27	#:use-module (guix i18n)
	28	#:use-module (guix modules)
	29	#:use-module (guix monads)
	30	#:use-module (guix records)
	31	#:use-module (guix remote)
5c793753	32	#:use-module (guix scripts system reconfigure)
fa9edf09 JK	33	#:use-module (guix ssh)
fa9edf09 JK	34	#:use-module (guix store)
fd3119db	35	#:use-module (guix utils)
fa9edf09 JK	36	#:use-module (ice-9 match)
fa9edf09 JK	37	#:use-module (srfi srfi-19)
5c793753	38	#:use-module (srfi srfi-26)
2c8e04f1	39	#:use-module (srfi srfi-34)
fa9edf09 JK	40	#:use-module (srfi srfi-35)
	41	#:export (managed-host-environment-type
	42
	43	machine-ssh-configuration
	44	machine-ssh-configuration?
	45	machine-ssh-configuration
	46
	47	machine-ssh-configuration-host-name
d84e9b75	48	machine-ssh-configuration-build-locally?
fa9edf09 JK	49	machine-ssh-configuration-port
	50	machine-ssh-configuration-user
	51	machine-ssh-configuration-session))
	52
	53	;;; Commentary:
	54	;;;
	55	;;; This module implements remote evaluation and system deployment for
53f21b3f	56	;;; machines that are accessible over SSH and have a known host-name. In the
fa9edf09 JK	57	;;; sense of the broader "machine" interface, we describe the environment for
	58	;;; such machines as 'managed-host.
	59	;;;
	60	;;; Code:
	61
	62	\f
	63	;;;
	64	;;; Parameters for the SSH client.
	65	;;;
	66
	67	(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
	68	make-machine-ssh-configuration
	69	machine-ssh-configuration?
	70	this-machine-ssh-configuration
d84e9b75	71	(host-name machine-ssh-configuration-host-name) ; string
2c8e04f1	72	(system machine-ssh-configuration-system) ; string
d84e9b75 JK	73	(build-locally? machine-ssh-configuration-build-locally?
	74	(default #t))
	75	(port machine-ssh-configuration-port ; integer
	76	(default 22))
	77	(user machine-ssh-configuration-user ; string
	78	(default "root"))
	79	(identity machine-ssh-configuration-identity ; path to a private key
	80	(default #f))
	81	(session machine-ssh-configuration-session ; session
	82	(default #f)))
fa9edf09 JK	83
	84	(define (machine-ssh-session machine)
	85	"Return the SSH session that was given in MACHINE's configuration, or create
	86	one from the configuration's parameters if one was not provided."
	87	(maybe-raise-unsupported-configuration-error machine)
	88	(let ((config (machine-configuration machine)))
	89	(or (machine-ssh-configuration-session config)
	90	(let ((host-name (machine-ssh-configuration-host-name config))
	91	(user (machine-ssh-configuration-user config))
	92	(port (machine-ssh-configuration-port config))
	93	(identity (machine-ssh-configuration-identity config)))
	94	(open-ssh-session host-name
	95	#:user user
	96	#:port port
	97	#:identity identity)))))
	98
	99	\f
	100	;;;
	101	;;; Remote evaluation.
	102	;;;
	103
5ea7537b JK	104	(define (machine-become-command machine)
	105	"Return as a list of strings the program and arguments necessary to run a
	106	shell command with escalated privileges for MACHINE's configuration."
	107	(if (string= "root" (machine-ssh-configuration-user
	108	(machine-configuration machine)))
	109	'()
	110	'("/run/setuid-programs/sudo" "-n" "--")))
	111
fa9edf09 JK	112	(define (managed-host-remote-eval machine exp)
	113	"Internal implementation of 'machine-remote-eval' for MACHINE instances with
	114	an environment type of 'managed-host."
	115	(maybe-raise-unsupported-configuration-error machine)
2c8e04f1 JK	116	(let ((config (machine-configuration machine)))
	117	(remote-eval exp (machine-ssh-session machine)
	118	#:build-locally?
	119	(machine-ssh-configuration-build-locally? config)
	120	#:system
	121	(machine-ssh-configuration-system config))))
fa9edf09 JK	122
fa9edf09 JK	123	\f
fd3119db JK	124	;;;
	125	;;; Safety checks.
	126	;;;
	127
	128	(define (machine-check-file-system-availability machine)
	129	"Raise a '&message' error condition if any of the file-systems specified in
	130	MACHINE's 'system' declaration do not exist on the machine."
	131	(define file-systems
	132	(filter (lambda (fs)
	133	(and (file-system-mount? fs)
	134	(not (member (file-system-type fs)
	135	%pseudo-file-system-types))
	136	(not (memq 'bind-mount (file-system-flags fs)))))
	137	(operating-system-file-systems (machine-operating-system machine))))
	138
	139	(define (check-literal-file-system fs)
	140	(define remote-exp
	141	#~(catch 'system-error
	142	(lambda ()
	143	(stat #$(file-system-device fs))
	144	#t)
	145	(lambda args
	146	(system-error-errno args))))
	147
	148	(mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
	149	(when (number? errno)
	150	(raise (condition
	151	(&message
	152	(message (format #f (G_ "device '~a' not found: ~a")
	153	(file-system-device fs)
	154	(strerror errno)))))))
	155	(return #t)))
	156
	157	(define (check-labeled-file-system fs)
	158	(define remote-exp
	159	(with-imported-modules '((gnu build file-systems))
	160	#~(begin
	161	(use-modules (gnu build file-systems))
	162	(find-partition-by-label #$(file-system-label->string
	163	(file-system-device fs))))))
	164
	165	(mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
	166	(unless result
	167	(raise (condition
	168	(&message
	169	(message (format #f (G_ "no file system with label '~a'")
	170	(file-system-label->string
	171	(file-system-device fs))))))))
	172	(return #t)))
	173
	174	(define (check-uuid-file-system fs)
	175	(define remote-exp
	176	(with-imported-modules (source-module-closure
	177	'((gnu build file-systems)
	178	(gnu system uuid)))
	179	#~(begin
	180	(use-modules (gnu build file-systems)
	181	(gnu system uuid))
	182
	183	(define uuid
	184	(string->uuid #$(uuid->string (file-system-device fs))))
	185
	186	(find-partition-by-uuid uuid))))
	187
188	(mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
189	(unless result
190	(raise (condition
191	(&message
192	(message (format #f (G_ "no file system with UUID '~a'")
193	(uuid->string (file-system-device fs))))))))
194	(return #t)))
195
196	(mbegin %store-monad
197	(mapm %store-monad check-literal-file-system
198	(filter (lambda (fs)
199	(string? (file-system-device fs)))
200	file-systems))
201	(mapm %store-monad check-labeled-file-system
202	(filter (lambda (fs)
203	(file-system-label? (file-system-device fs)))
204	file-systems))
205	(mapm %store-monad check-uuid-file-system
206	(filter (lambda (fs)
207	(uuid? (file-system-device fs)))
208	file-systems))))
209
210	(define (machine-check-initrd-modules machine)
211	"Raise a '&message' error condition if any of the modules needed by
212	'needed-for-boot' file systems in MACHINE are not available in the initrd."
213	(define file-systems
214	(filter file-system-needed-for-boot?
215	(operating-system-file-systems (machine-operating-system machine))))
216
217	(define (missing-modules fs)
218	(define remote-exp
219	(let ((device (file-system-device fs)))
220	(with-imported-modules (source-module-closure
221	'((gnu build file-systems)
222	(gnu build linux-modules)
223	(gnu system uuid)))
224	#~(begin
225	(use-modules (gnu build file-systems)
226	(gnu build linux-modules)
227	(gnu system uuid))
228
229	(define dev
230	#$(cond ((string? device) device)
231	((uuid? device) #~(find-partition-by-uuid
232	(string->uuid
233	#$(uuid->string device))))
234	((file-system-label? device)
235	#~(find-partition-by-label
236	(file-system-label->string #$device)))))
237
238	(missing-modules dev '#$(operating-system-initrd-modules
239	(machine-operating-system machine)))))))
240	(mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
241	(return (list fs missing))))
242
243	(mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
244	(for-each (match-lambda
245	((fs missing)
246	(unless (null? missing)
247	(raise (condition
248	(&message
249	(message (format #f (G_ "~a missing modules ~{ ~a~}~%")
250	(file-system-device fs)
251	missing))))))))
252	device)
253	(return #t)))
254
2c8e04f1 JK	255	(define (machine-check-building-for-appropriate-system machine)
	256	"Raise a '&message' error condition if MACHINE is configured to be built
	257	locally and the 'system' field does not match the '%current-system' reported
	258	by MACHINE."
	259	(let ((config (machine-configuration machine))
	260	(system (remote-system (machine-ssh-session machine))))
	261	(when (and (machine-ssh-configuration-build-locally? config)
	262	(not (string= system (machine-ssh-configuration-system config))))
	263	(raise (condition
	264	(&message
	265	(message (format #f (G_ "incorrect target system \
	266	('~a' was given, while the system reports that it is '~a')~%")
	267	(machine-ssh-configuration-system config)
	268	system)))))))
	269	(with-monad %store-monad (return #t)))
	270
fd3119db JK	271	(define (check-deployment-sanity machine)
	272	"Raise a '&message' error condition if it is clear that deploying MACHINE's
	273	'system' declaration would fail."
2c8e04f1 JK	274	;; Order is important here -- an incorrect value for 'system' will cause
2c8e04f1 JK	275	;; invocations of 'remote-eval' to fail.
fd3119db	276	(mbegin %store-monad
2c8e04f1	277	(machine-check-building-for-appropriate-system machine)
fd3119db JK	278	(machine-check-file-system-availability machine)
	279	(machine-check-initrd-modules machine)))
	280
	281	\f
fa9edf09 JK	282	;;;
	283	;;; System deployment.
	284	;;;
	285
fa9edf09 JK	286	(define (machine-boot-parameters machine)
	287	"Monadic procedure returning a list of 'boot-parameters' for the generations
	288	of MACHINE's system profile, ordered from most recent to oldest."
	289	(define bootable-kernel-arguments
	290	(@@ (gnu system) bootable-kernel-arguments))
	291
	292	(define remote-exp
	293	(with-extensions (list guile-gcrypt)
	294	(with-imported-modules (source-module-closure '((guix config)
	295	(guix profiles)))
	296	#~(begin
	297	(use-modules (guix config)
	298	(guix profiles)
	299	(ice-9 textual-ports))
	300
	301	(define %system-profile
	302	(string-append %state-directory "/profiles/system"))
	303
	304	(define (read-file path)
	305	(call-with-input-file path
	306	(lambda (port)
	307	(get-string-all port))))
	308
	309	(map (lambda (generation)
	310	(let* ((system-path (generation-file-name %system-profile
	311	generation))
	312	(boot-parameters-path (string-append system-path
	313	"/parameters"))
	314	(time (stat:mtime (lstat system-path))))
	315	(list generation
	316	system-path
	317	time
	318	(read-file boot-parameters-path))))
	319	(reverse (generation-numbers %system-profile)))))))
	320
	321	(mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
	322	(return
	323	(map (lambda (generation)
	324	(match generation
	325	((generation system-path time serialized-params)
	326	(let* ((params (call-with-input-string serialized-params
	327	read-boot-parameters))
	328	(root (boot-parameters-root-device params))
	329	(label (boot-parameters-label params)))
	330	(boot-parameters
	331	(inherit params)
	332	(label
	333	(string-append label " (#"
	334	(number->string generation) ", "
	335	(let ((time (make-time time-utc 0 time)))
	336	(date->string (time-utc->date time)
	337	"~Y-~m-~d ~H:~M"))
	338	")"))
	339	(kernel-arguments
	340	(append (bootable-kernel-arguments system-path root)
	341	(boot-parameters-kernel-arguments params))))))))
	342	generations))))
	343
fa9edf09 JK	344	(define (deploy-managed-host machine)
	345	"Internal implementation of 'deploy-machine' for MACHINE instances with an
	346	environment type of 'managed-host."
	347	(maybe-raise-unsupported-configuration-error machine)
fd3119db JK	348	(mlet %store-monad ((_ (check-deployment-sanity machine))
fd3119db JK	349	(boot-parameters (machine-boot-parameters machine)))
d97ce204	350	(let* ((os (machine-operating-system machine))
5c793753 JK	351	(eval (cut machine-remote-eval machine <>))
	352	(menu-entries (map boot-parameters->menu-entry boot-parameters))
	353	(bootloader-configuration (operating-system-bootloader os))
	354	(bootcfg (operating-system-bootcfg os menu-entries)))
	355	(mbegin %store-monad
	356	(switch-to-system eval os)
	357	(upgrade-shepherd-services eval os)
	358	(install-bootloader eval bootloader-configuration bootcfg)))))
fa9edf09 JK	359
	360	\f
	361	;;;
	362	;;; Environment type.
	363	;;;
	364
	365	(define managed-host-environment-type
	366	(environment-type
	367	(machine-remote-eval managed-host-remote-eval)
	368	(deploy-machine deploy-managed-host)
	369	(name 'managed-host-environment-type)
53f21b3f	370	(description "Provisioning for machines that are accessible over SSH
fa9edf09 JK	371	and have a known host-name. This entails little more than maintaining an SSH
	372	connection to the host.")))
	373
	374	(define (maybe-raise-unsupported-configuration-error machine)
	375	"Raise an error if MACHINE's configuration is not an instance of
	376	<machine-ssh-configuration>."
	377	(let ((config (machine-configuration machine))
	378	(environment (environment-type-name (machine-environment machine))))
	379	(unless (and config (machine-ssh-configuration? config))
	380	(raise (condition
	381	(&message
	382	(message (format #f (G_ "unsupported machine configuration '~a'
	383	for environment of type '~a'")
	384	config
	385	environment))))))))