add optional HOST arg to some accessors for hostattrs

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

7 files changed, 25 insertions, 27 deletions

diff --git a/src/deployment.lisp b/src/deployment.lisp
index 18c9ff0..226c55d 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -305,7 +305,7 @@ different user."
      (setf (getf (slot-value host 'hostattrs) :data) nil)
      (setq host (preprocess-host host))
      (doplist (k v (hostattrs host))
-              (loop with root = (getf (hostattrs *host*) k)
+              (loop with root = (get-hostattrs k)
                     for cell on v until (eq cell root)
                     collect (car cell) into accum
                     finally (apply #'push-hostattrs k (nreverse accum))))
@@ -323,7 +323,7 @@ different user."
 (defun %propagate-hostattrs (host)
   (dolist (system (propspec-systems (host-propspec host)))
     (pushnew system (slot-value (host-propspec *host*) 'systems)))
-  (dolist (attr (getf (hostattrs host) :data))
+  (dolist (attr (get-hostattrs :data host))
     (push-hostattrs :data attr)))
 
 (defprop evals :posix (&rest forms)
diff --git a/src/property.lisp b/src/property.lisp
index 8ac2c76..2abb5e9 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -453,20 +453,20 @@ other than constant values and propapps to property combinators."
 this property cannot be applied to this host.  E.g. the property will try to
 install an apt package but the host is FreeBSD.")
 
-(defun get-hostattrs (k)
+(defun get-hostattrs (k &optional (host *host*))
   "Retrieve the list of static informational attributes of type KEY.
 
 Called by property :HOSTATTRS, :APPLY and :UNAPPLY subroutines."
-  (getf (slot-value *host* 'hostattrs) k))
+  (getf (slot-value host 'hostattrs) k))
 
-(defun get-hostattrs-car (k)
-  (car (get-hostattrs k)))
+(defun get-hostattrs-car (k &optional (host *host*))
+  (car (get-hostattrs k host)))
 
-(defun get-parent-hostattrs (k)
-  (getf (get-hostattrs :parent-hostattrs) k))
+(defun get-parent-hostattrs (k &optional (host *host*))
+  (getf (get-hostattrs :parent-hostattrs host) k))
 
-(defun get-parent-hostattrs-car (k)
-  (car (get-parent-hostattrs k)))
+(defun get-parent-hostattrs-car (k &optional (host *host*))
+  (car (get-parent-hostattrs k host)))
 
 (defun push-hostattrs (k &rest vs)
   "Push new static informational attributes VS of type KEY.
@@ -489,11 +489,12 @@ is needed to deploy a property.
 Called by property :HOSTATTRS subroutines."
   (pushnew-hostattrs :data (cons iden1 iden2)))
 
-(defun get-hostname ()
-  "Get the hostname of the host to which properties are being applied.
+(defun get-hostname (&optional (host *host*))
+  "Get the hostname of HOST, defaulting to the host to which properties are
+being applied.
 
 Called by property subroutines."
-  (get-hostattrs-car :hostname))
+  (get-hostattrs-car :hostname host))
 
 
 ;;;; :APPLY subroutines
diff --git a/src/property/chroot.lisp b/src/property/chroot.lisp
index 2ffa879..cdff3d0 100644
--- a/src/property/chroot.lisp
+++ b/src/property/chroot.lisp
@@ -28,7 +28,7 @@
        (progn (delete-remote-trees root) nil)
        (remote-exists-p (merge-pathnames "usr/lib/os-release" root))))
   (:apply
-   (let* ((os (car (getf (hostattrs host) :os)))
+   (let* ((os (get-hostattrs-car :os host))
           (args (list "debootstrap"
                       (plist-to-cmd-args options)
                       (strcat "--arch=" (os:debian-architecture os))
@@ -92,7 +92,7 @@ starting services in the chroot, and set up access to parent hostattrs."
 OPTIONS is a plist of values to pass to the OS-specific bootstrapping property."
   (:desc
    (declare (ignore options))
-   #?"Built chroot for ${(car (getf (hostattrs host) :hostname))} @ ${root}")
+   #?"Built chroot for ${(get-hostname host)} @ ${root}")
   (%os-bootstrapper-installed child-host*)
   (%os-bootstrapped options root child-host*)
   (consfigurator:deploys `((:chroot :into ,root)) child-host))
diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 29e163d..f82460e 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -851,15 +851,13 @@ least the following:
 Unless REBUILD, the image will not be repartitioned even if the specification
 of the host's volumes changes, although the contents of the image's
 filesystems will be incrementally updated when other properties change."
-  (:desc (declare (ignore options rebuild))
-         (let ((hostname (car (getf (hostattrs host) :hostname))))
-           #?"Built image for ${hostname} @ ${image-pathname}"))
+  (:desc #?"Built image for ${(get-hostname host)} @ ${image-pathname}")
   (let ((chroot (ensure-directory-pathname
                  (strcat (unix-namestring image-pathname) ".chroot")))
         (volumes
           (loop
             with found
-            for volume in (getf (hostattrs (preprocess-host host)) :volumes)
+            for volume in (get-hostattrs :volumes (preprocess-host host))
             for physical-disk-p = (subtypep (type-of volume) 'physical-disk)
             if (and physical-disk-p (not found)
                     (slot-boundp volume 'volume-contents))
diff --git a/src/property/libvirt.lisp b/src/property/libvirt.lisp
index 1e7d41f..9c15625 100644
--- a/src/property/libvirt.lisp
+++ b/src/property/libvirt.lisp
@@ -65,9 +65,7 @@ On Debian, it is not started by default after installation of libvirt."
 
 (defmethod os-variant (os))
 
-(defprop defined :posix
-    (host &rest arguments
-          &aux (hostname (car (getf (hostattrs host) :hostname))))
+(defprop defined :posix (host &rest arguments)
   "Define a libvirt domain for HOST by providing ARGUMENTS to virt-install(1).
 With the current implementation, if ARGUMENTS changes, virt-install(1) will
 not be run again.  You will need to either unapply and reapply this property,
@@ -76,7 +74,7 @@ or use virt-xml(1) to perform a modification.
 Unapplying this property when the domain is running will use the 'undefine'
 subcommand of virsh(1) to convert the running domain into a transient domain."
   (:check (declare (ignore arguments))
-          (remote-exists-p (merge-pathnames (strcat hostname ".xml")
+          (remote-exists-p (merge-pathnames (strcat (get-hostname host) ".xml")
                                             "/etc/libvirt/qemu/")))
   (:apply
    (with-remote-temporary-file (file)
@@ -84,11 +82,12 @@ subcommand of virsh(1) to convert the running domain into a transient domain."
       (format
        nil
        "virt-install --print-xml -n ~A~:[~; --os-variant=~:*~A~]~{ ~A~} >~S"
-       hostname (os-variant host) (mapcar #'escape-sh-token arguments) file))
+       (get-hostname host) (os-variant host)
+       (mapcar #'escape-sh-token arguments) file))
      (mrun "virsh" "define" file)))
   (:unapply
    (declare (ignore arguments))
-   (mrun "virsh" "undefine" hostname)))
+   (mrun "virsh" "undefine" (get-hostname host))))
 
 (defun virsh-get-columns (&rest arguments)
   "Run a virsh command that is expected to yield tabular output, with the given
diff --git a/src/property/live-build.lisp b/src/property/live-build.lisp
index c83050e..e729234 100644
--- a/src/property/live-build.lisp
+++ b/src/property/live-build.lisp
@@ -99,7 +99,7 @@ and might undo some of their effects.  For example, to configure
                                 (merge-pathnames "config/" dir))
                         '("binary" "bootstrap" "chroot" "common" "source")))
          (host (make-host :propspec properties))
-         (host-os (car (getf (hostattrs (preprocess-host host)) :os))))
+         (host-os (get-hostattrs-car :os (preprocess-host host))))
     (when-let ((mirror (get-hostattrs-car :apt.mirror)))
       (setq config (list* "-m" mirror config)))
     (setq config (list* "-a" (os:debian-architecture host-os)
diff --git a/src/property/os.lisp b/src/property/os.lisp
index 42d0c5c..cec032d 100644
--- a/src/property/os.lisp
+++ b/src/property/os.lisp
@@ -85,7 +85,7 @@
 
 (defun typecase-host (host)
   (class-of (if host
-                (car (getf (hostattrs host) :os))
+                (get-hostattrs-car :os host)
                 (get-hostattrs-car :os))))
 
 (defun typecase-choose (host cases)