1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
;;; Consfigurator -- Lisp declarative configuration management system
;;; Copyright (C) 2021-2022 Sean Whitton <spwhitton@spwhitton.name>
;;; This file 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, or (at your option)
;;; any later version.
;;; This file 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 this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :consfigurator.property.chroot)
(named-readtables:in-readtable :consfigurator)
(defprop %debootstrapped :posix (root host &rest options)
"Bootstrap The Universal Operating System into ROOT using debootstrap(1)."
(:check
(declare (ignore options host))
;; check whether a previous debootstrap failed partway through
(if (remote-test "-d" (merge-pathnames "debootstrap/"
(ensure-directory-pathname root)))
(progn (delete-remote-trees root) nil)
(remote-exists-p (chroot-pathname "/usr/lib/os-release" root))))
(:apply
(destructuring-bind
(&key (apt.proxy (get-hostattrs-car :apt.proxy host))
(apt.mirror (get-hostattrs-car :apt.mirrors host))
&allow-other-keys
&aux (os (get-hostattrs-car :os host))
(args (list "debootstrap"
(plist-to-long-options
(remove-from-plist options :apt.proxy :apt.mirrors))
(strcat "--arch=" (os:debian-architecture-string os))
(os:debian-suite os)
root)))
options
;; In the case where the chroot arch is not equal to the host arch, we
;; could execute arch-test(1) here to confirm the architecture is
;; executable by the running kernel; we'd add arch-test alongside
;; qemu-user-static in %OS-BOOTSTRAPPER-INSTALLED. Or possibly we only
;; try to execute arch-test(1) when we find it's already on PATH.
(when apt.proxy
(setq args (list* :env (list :http_proxy apt.proxy) args)))
(when apt.mirror
(nconcf args (list apt.mirror)))
(apply #'run args))))
(defproplist %debootstrap-manually-installed :posix ()
;; Accept any debootstrap we find on path to enable installing Debian on
;; arbitrary unixes, where Consfigurator does not know how to install
;; packages, but the user has manually installed debootstrap(8).
(:check (remote-executable-find "debootstrap"))
(package:installed nil '(:apt ("debootstrap"))))
(defpropspec %os-bootstrapper-installed :posix (host)
(:desc "OS bootstrapper installed")
(let ((host (preprocess-host host)))
`(os:host-etypecase ,host
(debian
(os:typecase
(debianlike (apt:installed "debootstrap"))
(t (%debootstrap-manually-installed)))
;; Don't have an escape hatch like the :CHECK subroutine of
;; %DEBOOTSTRAP-MANUALLY-INSTALLED for the case where the
;; architectures do not match because ensuring that debootstrap(8)
;; will be able to bootstrap a foreign arch is more involved.
,@(and (compute-applicable-methods
#'os:supports-arch-p
(list (get-hostattrs-car :os) (get-hostattrs-car :os host)))
(not (os:supports-arch-p
(get-hostattrs-car :os) (get-hostattrs-car :os host)))
'((os:etypecase
(debianlike (apt:installed "qemu-user-static")))))))))
(defpropspec %os-bootstrapped :posix (options root host)
"Bootstrap OS into ROOT, e.g. with debootstrap(1)."
;; evaluate HOST once; can't use ONCE-ONLY because gensyms not serialisable
;; for sending to remote Lisp images
(:desc (declare (ignore options root host)) "OS bootstrapped")
(let ((host host))
`(os:host-etypecase ,host
(debian (%debootstrapped ,root ,host ,@options)))))
(defmethod %make-child-host ((host unpreprocessed-host))
(let ((propspec (host-propspec host)))
(make-child-host
:hostattrs (hostattrs host)
:propspec (make-propspec
:systems (propspec-systems propspec)
:propspec `(service:without-starting-services
(container:contained :filesystem)
,(propspec-props propspec))))))
(defproplist deploys :lisp (root host &optional additional-properties)
"Like DEPLOYS with first argument `((:chroot :into ,root)), but disable
starting services in the chroot, and set up access to parent hostattrs."
(:desc #?"Subdeployment of ${root}")
(consfigurator:deploys
`((:chroot :into ,root))
(%make-child-host (union-propspec-into-host host additional-properties))))
(defproplist deploys-these :lisp (root host properties)
"Like DEPLOYS-THESE with first argument `((:chroot :into ,root)), but disable
starting services in the chroot, and set up access to parent hostattrs."
(:desc #?"Subdeployment of ${root}")
(consfigurator:deploys
`((:chroot :into ,root))
(%make-child-host
(replace-propspec-into-host (ensure-host host) properties))))
(defproplist os-bootstrapped-for :lisp
(options root host &optional additional-properties
&aux
(child-host (%make-child-host
(union-propspec-into-host host additional-properties)))
(child-host* (preprocess-host child-host)))
"Bootstrap an OS for HOST into ROOT and apply the properties of HOST.
OPTIONS is a plist of values to pass to the OS-specific bootstrapping property."
(:desc
(declare (ignore options))
#?"Built chroot for ${(get-hostname child-host*)} @ ${root}")
(with-unapply
(%os-bootstrapper-installed child-host*)
(%os-bootstrapped options root child-host*)
(consfigurator:deploys `((:chroot :into ,root)) child-host)
:unapply (mount:unmounted-below-and-removed root)))
(defproplist os-bootstrapped :lisp (options root properties)
"Bootstrap an OS into ROOT and apply PROPERTIES.
OPTIONS is a plist of values to pass to the OS-specific bootstrapping property."
(:desc (declare (ignore options properties))
#?"Built chroot @ ${root}")
(os-bootstrapped-for options root (make-host :propspec properties)))
|
