add INSTALLER:CLEANLY-INSTALLED-ONCE & some utils

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 185 insertions, 0 deletions

diff --git a/src/property/installer.lisp b/src/property/installer.lisp
index c270bdf..6b7b396 100644
--- a/src/property/installer.lisp
+++ b/src/property/installer.lisp
@@ -132,3 +132,188 @@ install a package providing /usr/sbin/grub-install, but it won't execute it."
        (setq propspecs (delete-duplicates propspecs :test #'tree-equal))
        (return
          (if (cdr propspecs) (cons 'eseqprops propspecs) (car propspecs)))))
+
+
+;;;; Live replacement of GNU/Linux distributions
+
+;;; This is based on Propellor's OS.cleanInstallOnce property -- very cool!
+;;;
+;;; We prepare only a base system chroot, and then apply the rest of the
+;;; host's properties after the flip, rather than applying all of the host's
+;;; properties to the chroot and only then flipping.  This has the advantage
+;;; that properties which normally restrict themselves when running in a
+;;; chroot will instead apply all of their changes.  There could be failures
+;;; due to still running the old OS's kernel and init system, however, which
+;;; might be avoided by applying the properties only to the chroot.
+;;;
+;;; Another option would be a new SERVICES:WITHOUT-STARTING-SERVICES-UNTIL-END
+;;; which would disable starting services and push the cleanup forms inside
+;;; the definition of SERVICES:WITHOUT-STARTING-SERVICES to *AT-END-FUNCTIONS*
+;;; in a closure.  We'd also want %CONSFIGURE to use UNWIND-PROTECT-IN-PARENT
+;;; to ensure that the AT-END functions get run even when there's a nonlocal
+;;; exit from %CONSFIGURE's call to PROPAPPAPPLY; perhaps we could pass a
+;;; second argument to the AT-END functions indicating whether there was a
+;;; non-local transfer of control.  REBOOT:REBOOTED-AT-END might only reboot
+;;; when there was a normal return from PROPAPPAPPLY, whereas the cleanup
+;;; forms from SERVICES:WITHOUT-STARTING-SERVICES would always be evaluated.
+
+(defprop %root-filesystems-flipped :lisp (new-os old-os)
+  (:hostattrs (os:required 'os:linux))
+  (:apply
+   (assert-euid-root)
+   (let ((new-os (ensure-directory-pathname new-os))
+         (old-os
+           (ensure-directories-exist (ensure-directory-pathname old-os)))
+         (preserved-directories
+           '(;; These dirs can contain sockets, remote Lisp image output,
+             ;; etc.; avoid upsetting those.
+             #P"/run/" #P"/tmp/"
+             ;; Makes sense to keep /proc until we replace the running init.
+             #P"/proc/")))
+     (flet ((preservedp (pathname)
+              (member pathname preserved-directories :test #'pathname-equal)))
+       (mount:assert-devtmpfs-udev-/dev)
+
+       ;; We are not killing any processes, so lazily unmount everything
+       ;; before trying to perform any renames.  (Present structure of this
+       ;; loop assumes that each member of PRESERVED-DIRECTORIES is directly
+       ;; under '/'.)
+       ;;
+       ;; We use system(3) to mount and unmount because once we unmount /dev,
+       ;; there may not be /dev/null anymore, depending on whether the root
+       ;; filesystems of the old and new OSs statically contain the basic /dev
+       ;; entries or not, and at least on SBCL on Debian UIOP:RUN-PROGRAM
+       ;; wants to open /dev/null when executing a command with no input.
+       ;; Another option would be to pass an empty string as input.
+       (loop with sorted = (cdr (mount:all-mounts)) ; drop '/' itself
+             as next = (pop sorted)
+             while next
+             do (loop while (subpathp (car sorted) next) do (pop sorted))
+             unless (preservedp next)
+               do (system "umount" "--recursive" "--lazy" next))
+
+       (let (done)
+         (handler-case
+             (flet ((rename (s d) (rename-file s d) (push (cons s d) done)))
+               (dolist (file (directory-contents #P"/"))
+                 (unless (or (preservedp file)
+                             (pathname-equal file new-os)
+                             (pathname-equal file old-os))
+                   (rename file (chroot-pathname file old-os))))
+               (dolist (file (directory-contents new-os))
+                 (let ((dest (in-chroot-pathname file new-os)))
+                   (unless (or (preservedp dest)
+                               (file-exists-p dest)
+                               (directory-exists-p dest))
+                     (rename file dest)))))
+           (serious-condition (c)
+             ;; Make a single attempt to undo the moves to increase the chance
+             ;; we can fix things and try again.
+             (loop for (source . dest) in done do (rename-file dest source))
+             (signal c))))
+       (delete-directory-tree new-os :validate t)
+
+       ;; For the freshly bootstrapped OS let's assume that HOME is /root and
+       ;; XDG_CACHE_HOME is /root/.cache; we do want to try to read the old
+       ;; OS's actual XDG_CACHE_HOME.  Move cache & update environment.
+       (let ((source
+               (chroot-pathname
+                (merge-pathnames "consfigurator/"
+                                 (ensure-directory-pathname
+                                  (or (getenv "XDG_CACHE_HOME")
+                                      (strcat (getenv "HOME") "/.cache/"))))
+                old-os)))
+         (when (directory-exists-p source)
+           (rename-file source (ensure-directories-exist
+                                #P"/root/.cache/consfigurator/"))))
+       (posix-login-environment "root" "/root")
+
+       ;; Remount virtual filesystems that other properties we will apply
+       ;; might require (esp. relevant for installing bootloaders).
+       (dolist (mount mount:*standard-linux-vfs*)
+         (unless (preservedp (ensure-directory-pathname (lastcar mount)))
+           (apply #'system "mount" mount)))
+       (when (and (not (preservedp #P"/sys/"))
+                  (directory-exists-p "/sys/firmware/efi/efivars"))
+         (apply #'mrun "mount" mount:*linux-efivars-vfs*))))))
+
+(defproplist cleanly-installed-once :lisp
+    (&optional options (original-os '(os:linux :amd64))
+               &aux (minimal-new-host
+                     (make-host :hostattrs (list :os (get-hostattrs :os))))
+               (original-host
+                (make-host
+                 :propspec
+                 (make-propspec
+                  :propspec
+                  `(eseqprops ,original-os
+                              (chroot:os-bootstrapped-for
+                               ,options "/new-os" ,minimal-new-host))))))
+  "Replaces whatever operating system the host has with a clean installation of
+the OS that the host is meant to have, and reboot, once.  This is intended for
+freshly launched machines in faraway datacentres, where your provider has
+installed some operating system image to get you started, but you'd like have
+a greater degree of control over the contents and configuration of the
+machine.  For example, this can help you ensure that the operation of the host
+does not implicitly depend upon configuration present in the provider's image
+but not captured by your consfig.  This property's approach can fail and leave
+the system unbootable, but it's an time-efficient way to ensure that you're
+starting from a truly clean slate for those cases in which it works.
+
+ORIGINAL-OS is a propapp specifying the old OS, as you would apply to a host
+with that OS.  It will be used when trying to install the OS bootstrapper.
+For example, if you're trying to switch a host from a provider's Debian
+\"buster\" image to upstream Debian \"bullseye\", passing '(OS:DEBIAN-STABLE
+\"buster\" :AMD64) would cause Consfigurator to use apt to install
+debootstrap(8).  Alternatively, you can pass '(OS:LINUX :AMD64) and install
+the bootstrapper manually; this is useful for OSs whose package managers
+Consfigurator doesn't yet know how to drive.  You might apply an OS-agnostic
+property before this one which manually downloads the bootstrapper and puts it
+on PATH.
+
+OPTIONS will be passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see.
+
+The files from the old OS will be left in '/old-os'.  Typically you will need
+to perform some additional configuration before rebooting to increase the
+likelihood that the system boots and is network-accessible.  This might
+require copying information from '/old-os' and/or the kernel's state before
+the reboot. Some of this will need to be attached to the application of this
+property using ON-CHANGE, whereas other fixes can just be applied subsequent
+to this property.  Here are two examples.  If you already know the machine's
+network configuration you might use
+
+    (os:debian-stable \"bullseye\" :amd64)
+    (installer:cleanly-installed-once ...)
+    (network:static \"ens3\" \"1.2.3.4\" ...)
+    (file:has-content \"/etc/resolv.conf\" ...)
+
+whereas if you don't have that information, you would want something like
+
+    (os:debian-stable \"bullseye\" :amd64)
+    (on-change (installer:cleanly-installed-once ...)
+      (file:is-copy-of \"/etc/resolv.conf\" \"/old-os/etc/resolv.conf\"))
+    (network:preserve-static-once)
+
+Here are some other propapps you might want to attach to the application of
+this property with ON-CHANGE:
+
+    (file:is-copy-of \"/etc/fstab\" \"/old-os/etc/fstab\")
+    (file:is-copy-of \"/root/.ssh/authorized_keys\"
+                     \"/old-os/root/.ssh/authorized_keys\")
+    (mount:unmounted-below-and-removed \"/old-os\")
+
+You will probably need to install a kernel, bootloader, sshd etc. in the list
+of properties subsequent to this one.
+
+If the system is not freshly provisioned, you couldn't easily recover from the
+system becoming unbootable, or you have physical access to the machine, it is
+probably better to use Consfigurator to build a disk image, or boot into a
+live system and use Consfigurator to install to the host's usual storage."
+  (:desc "OS cleanly installed once")
+  (:hostattrs (os:required 'os:linux))
+  (with-flagfile "/etc/consfigurator/os-cleanly-installed"
+    (deploys :local original-host)
+    (%root-filesystems-flipped "/new-os" "/old-os")
+    ;; Prevent boot issues caused by disabled shadow passwords.
+    (cmd:single "shadowconfig" "on")
+    (reboot:rebooted-at-end)))