add INSTALLER:CLEANLY-INSTALLED-ONCE & some utils

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

4 files changed, 221 insertions, 1 deletions

diff --git a/src/connection/sbcl.lisp b/src/connection/sbcl.lisp
index 1da961c..fb862aa 100644
--- a/src/connection/sbcl.lisp
+++ b/src/connection/sbcl.lisp
@@ -35,6 +35,13 @@ recommended."))
   (unless (zerop (mrun :for-exit "command" "-v" "sbcl"))
     ;; If we're not the final hop then we don't know the OS of the host to
     ;; which we're currently connected, so we can't apply SBCL-AVAILABLE.
+    ;;
+    ;; TODO In the case of INSTALLER:CLEANLY-INSTALLED-ONCE this code will
+    ;; have us trying to use apt to install sbcl on a Fedora host, say, upon
+    ;; the first connection, before Debian has been installed.  Perhaps we
+    ;; should just have some code which tries to install sbcl based on the
+    ;; package manager(s) it can find on PATH.  Could reuse that code for
+    ;; CHROOT::%DEBOOTSTRAP-MANUALLY-INSTALLED.
     (if remaining
         (failed-change "sbcl not on PATH and don't know how to install.")
         (sbcl-available)))
diff --git a/src/package.lisp b/src/package.lisp
index 8d54b4d..6665a48 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -22,6 +22,7 @@
                           #:ensure-directory-pathname
                           #:ensure-pathname
                           #:enough-pathname
+                          #:pathname-equal
                           #:subpathp
                           #:getenv
                           #:subdirectories
@@ -52,6 +53,7 @@
            #:ensure-directory-pathname
            #:ensure-pathname
            #:enough-pathname
+           #:pathname-equal
            #:subpathp
            #:getenv
            #:subdirectories
@@ -76,6 +78,7 @@
            #:plist-to-cmd-args
 	   #:with-local-temporary-directory
            #:pathname-file
+           #:directory-contents
            #:ensure-trailing-slash
            #:drop-trailing-slash
            #:quote-nonselfeval
@@ -87,6 +90,7 @@
            #:defpackage-consfig
            #:lambda-ignoring-args
            #:parse-cidr
+           #:system
 
            #:*consfigurator-debug-level*
            #:with-indented-inform
@@ -585,14 +589,18 @@
 (defpackage :consfigurator.property.installer
   (:use #:cl #:alexandria #:consfigurator #:consfigurator.property.disk)
   (:local-nicknames (#:os        #:consfigurator.property.os)
+                    (#:cmd       #:consfigurator.property.cmd)
                     (#:file      #:consfigurator.property.file)
                     (#:chroot    #:consfigurator.property.chroot)
+                    (#:mount     #:consfigurator.property.mount)
                     (#:fstab     #:consfigurator.property.fstab)
+                    (#:reboot    #:consfigurator.property.reboot)
                     (#:crypttab  #:consfigurator.property.crypttab))
   (:export #:install-bootloader-propspec
            #:install-bootloader-binaries-propspec
            #:chroot-installed-to-volumes
-           #:bootloader-binaries-installed))
+           #:bootloader-binaries-installed
+           #:cleanly-installed-once))
 
 (defpackage :consfigurator.property.grub
   (:use #:cl #:alexandria #:consfigurator
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)))
diff --git a/src/util.lisp b/src/util.lisp
index 7fc2997..24ec85e 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -169,6 +169,14 @@ one solution is to convert your property to a :LISP property."
             (enough-pathname pathname (pathname-directory-pathname pathname))
             pathname))))
 
+(defun directory-contents (pathname)
+  "Return the immediate contents of PATHNAME, a directory, without resolving
+symlinks.  Not suitable for use by :POSIX properties."
+  ;; On SBCL on Debian UIOP:*WILD-FILE-FOR-DIRECTORY* is #P"*.*".
+  (uiop:directory*
+   (merge-pathnames uiop:*wild-file-for-directory*
+                    (ensure-directory-pathname pathname))))
+
 (defun ensure-trailing-slash (namestring)
   (if (string-suffix-p namestring "/")
       namestring
@@ -297,6 +305,18 @@ expansion as a starting point for your own DEFPACKAGE form for your consfig."
                                        else do (princ #\: s)
                                                (loop-finish)))))))))
 
+(defun system (&rest args)
+  "Simple wrapper around system(3)."
+  (foreign-funcall
+   "system" :string (if (cdr args)
+                        (escape-sh-command
+                         (loop for arg in args
+                               if (pathnamep arg)
+                                 collect (unix-namestring arg)
+                               else collect arg))
+                        (car args))
+   :int))
+
 
 ;;;; Progress & debug printing