move OS::ARCHITECTURE slot from OS:LINUX to OS:DEBIANLIKE

We already use this information in the sense of a distribution architecture
rather than a kernel architecture, and the latter are differently grained.
We might later want to have slots for both.

Make OS:SUPPORTS-ARCH-P take OS objects as this simplifies existing usage.

Restore the ORIGINAL-OS parameter to INSTALLER:CLEANLY-INSTALLED-ONCE.  It was
previously replaced in 446b8f4a8ef78cb4605cfb551255bb455be411f0.
CHROOT::%OS-BOOTSTRAPPER-INSTALLED does not need the original host's
architecture in most cases, and accepting an arbitrary propapp means we don't
force the use of PACKAGE:INSTALLED.

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

5 files changed, 55 insertions, 51 deletions

diff --git a/src/property/chroot.lisp b/src/property/chroot.lisp
index a61a9f5..e2b032f 100644
--- a/src/property/chroot.lisp
+++ b/src/property/chroot.lisp
@@ -36,7 +36,7 @@
           (args (list "debootstrap"
                       (plist-to-long-options
                        (remove-from-plist options :apt.proxy :apt.mirrors))
-                      (strcat "--arch=" (os:debian-architecture os))
+                      (strcat "--arch=" (os:debian-architecture-string os))
                       (os:debian-suite os)
                       root)))
        options
@@ -72,9 +72,11 @@
         ;; %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 (not (os:supports-arch-p
-                     (get-hostattrs-car :os) (os:linux-architecture
-                                              (get-hostattrs-car :os host))))
+        ,@(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")))))))))
 
diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 3093280..ac55e9e 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -983,7 +983,7 @@ Currently only BIOS boot is implemented."
                      "live-boot" "task-laptop" "libnss-myhostname"
                      "syslinux-common" "isolinux")
                     (caches-cleaned))))))
-         (host-arch (os:linux-architecture (get-hostattrs-car :os host))))
+         (host-arch (os:debian-architecture (get-hostattrs-car :os host))))
       options
     (unless (member host-arch '(:amd64))
       (inapplicable-property
diff --git a/src/property/installer.lisp b/src/property/installer.lisp
index d3e4311..83a7b75 100644
--- a/src/property/installer.lisp
+++ b/src/property/installer.lisp
@@ -303,18 +303,17 @@ using a combinator like ON-CHANGE, or applied manually with DEPLOY-THESE."
          (apply #'mrun "mount" efi-system-partition-mount-args))))))
 
 (defproplist cleanly-installed-once :lisp
-    (original-os-architecture
-     &optional options
-     &aux (minimal-new-host
-	   (make-host :hostattrs (list :os (get-hostattrs :os))))
-     (original-host
-      (make-host
-       :propspec
-       (make-propspec
-        :propspec
-        `(eseqprops
-          (os:linux ,original-os-architecture)
-          (chroot:os-bootstrapped-for ,options "/new-os" ,minimal-new-host))))))
+    (&optional options original-os
+               &aux
+               (new (make-host :hostattrs `(:os ,(get-hostattrs :os))))
+               (original-host
+                (make-host
+                 :propspec
+                 (make-propspec
+                  :propspec
+                  `(eseqprops
+                    ,(or original-os '(os:linux))
+                    (chroot:os-bootstrapped-for ,options "/new-os" ,new))))))
   "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
@@ -326,17 +325,19 @@ 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-ARCHITECTURE is the architecture of the original OS as would be
-supplied to the OS:LINUX property, e.g. :AMD64.  OPTIONS will be passed on to
-CHROOT:OS-BOOTSTRAPPED-FOR, which see.
-
-The internal property CHROOT::%OS-BOOTSTRAPPER-INSTALLED will attempt to use
-PACKAGE:INSTALLED to install the OS bootstrapper (e.g. debootstrap(8) for
-Debian).  Alternatively, you can install the bootstrapper manually before
-running Consfigurator; this is useful for original 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.
+ORIGINAL-OS, if supplied, is a propapp specifying the old OS, as you would
+apply to a host with that OS.
+
+The internal property CHROOT::%OS-BOOTSTRAPPER-INSTALLED will attempt to
+install the OS bootstrapper (e.g. debootstrap(8) for Debian).  If ORIGINAL-OS
+is supplied then installation will use a package manager property for that OS.
+Otherwise, CHROOT::%OS-BOOTSTRAPPER-INSTALLED will fall back to trying
+PACKAGE:INSTALLED.  Alternatively, you can install the bootstrapper manually
+before running Consfigurator and not supply ORIGINAL-OS.  This is useful for
+original 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.
 
 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
diff --git a/src/property/os.lisp b/src/property/os.lisp
index d04c262..86245cc 100644
--- a/src/property/os.lisp
+++ b/src/property/os.lisp
@@ -22,22 +22,22 @@
 
 (defclass unixlike () ())
 
-(defclass linux (unixlike)
-  ((architecture
-    :initarg :arch :reader linux-architecture
-    :documentation
-    "Keyword whose name is Debian's name for this architecture, e.g. :AMD64")))
+(defclass linux (unixlike) ())
 
-(defprop linux :posix (architecture)
+(defprop linux :posix ()
   (:desc "Host kernel is Linux")
-  (:hostattrs (push-hostattr :os (make-instance 'linux :arch architecture))))
+  (:hostattrs (push-hostattr :os (make-instance 'linux))))
 
 (define-simple-print-object linux)
 
 (defclass debianlike (linux) ())
 
 (defclass debian (debianlike)
-  ((suite :initarg :suite
+  ((architecture
+    :initarg :arch :reader debian-architecture
+    :documentation
+    "Keyword whose name is Debian's name for this architecture, e.g. :AMD64")
+   (suite :initarg :suite
           :reader debian-suite
           :initform (error "Must provide suite"))))
 
@@ -81,9 +81,9 @@
 (defclass debian-experimental (debian)
   ((suite :initform "experimental")))
 
-(defmethod debian-architecture ((os linux))
+(defmethod debian-architecture-string ((os debian))
   "Return a string representing the architecture of OS as used by Debian."
-  (string-downcase (symbol-name (linux-architecture os))))
+  (string-downcase (symbol-name (debian-architecture os))))
 
 
 ;;;; Property combinators
@@ -144,12 +144,12 @@ Used in property :HOSTATTRS subroutines."
     (unless (and os (subtypep os type))
       (inapplicable-property #?"Property requires OS of type ${type}"))))
 
-(defun supports-arch-p (os arch)
-  "Can binaries of type ARCH run on OS?"
-  (let ((same (eq (linux-architecture os) arch)))
-    (cl:typecase os
-      (debian (or same
-                  (member arch (assoc (linux-architecture os)
-                                      '((:amd64 :i386)
-                                        (:i386  :amd64))))))
-      (linux same))))
+(defgeneric supports-arch-p (target-os binary-os)
+  (:documentation "Can binaries for BINARY-OS run on TARGET-OS?"))
+
+(defmethod supports-arch-p ((target-os debian) (binary-os debian))
+  (let ((target (debian-architecture target-os))
+        (binary (debian-architecture binary-os)))
+    (or (eq target binary)
+        (member binary (assoc target '((:amd64 :i386)
+                                       (:i386  :amd64)))))))
diff --git a/src/property/sbuild.lisp b/src/property/sbuild.lisp
index e0ce023..3a3533d 100644
--- a/src/property/sbuild.lisp
+++ b/src/property/sbuild.lisp
@@ -52,7 +52,7 @@ exist, so that the user can easily override this default."
                           (debianlike (apt:installed "eatmydata" "ccache"))))))))
              (os (get-hostattrs-car :os host))
              (suite (os:debian-suite os))
-             (arch (os:debian-architecture os)))
+             (arch (os:debian-architecture-string os)))
   "Build and configure a schroot for use with sbuild.
 For convenience we set up several enhancements, such as ccache and eatmydata.
 In the case of Debian, we assume you are building for Debian stretch or newer,
@@ -156,8 +156,9 @@ EOF :mode #o755)
               ;; to avoid more than one schroot getting the same aliases, we
               ;; only do this if the arch of the chroot equals the host arch.
               ,@(and (string= suite "unstable")
-                     (string= arch (os:debian-architecture
-                                    (get-hostattrs-car :os)))
+                     (string=
+                      arch
+                      (os:debian-architecture-string (get-hostattrs-car :os)))
                      `(("aliases"
                         ,(format
                           nil "~@{~A~^,~}"
@@ -172,7 +173,7 @@ EOF :mode #o755)
                           "UNRELEASED"
                           ;; The following is for dgit compatibility.
                           (strcat "UNRELEASED-"
-                                  (os:debian-architecture os)
+                                  (os:debian-architecture-string os)
                                   "-sbuild")))))
 
               ("command-prefix"