add & propagate :NO-SERVICES connattr and respect in LIBVIRT:STARTED

This change was prompted by the realisation that RECONNECTS nullifies any
enclosing SERVICE:WITHOUT-STARTING-SERVICES because *HOST* during RECONNECTS
is a distinct HOST value, computed at hostattrs time, which can't be affected
by an enclosing combinator that works by temporarily pushing hostattrs at
:APPLY time.  So, for example, if we chroot and subsequently establish a
:SETUID connection, properties might try to start services as the non-root
user and there is no way for them to know they shouldn't.

We can avoid this problem by using a connattr instead because we have a
mechanism for propagating connattrs to subsequently established connections.
And as in most cases the reason for not starting services is solely due to the
way in which we're connecting to the host, a connattr is more appropriate.

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

6 files changed, 29 insertions, 7 deletions

diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index 5c149e3..8f829d3 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -86,6 +86,10 @@ should be the mount point, without the chroot's root prefixed.")
     ((type (eql :remote-gid)) connattr (connection chroot-connection))
   connattr)
 
+(defmethod propagate-connattr
+    ((type (eql :no-services)) connattr (connection chroot-connection))
+  connattr)
+
 
 ;;;; :CHROOT.FORK
 
diff --git a/src/connection/setuid.lisp b/src/connection/setuid.lisp
index 2036146..59b9e67 100644
--- a/src/connection/setuid.lisp
+++ b/src/connection/setuid.lisp
@@ -65,3 +65,7 @@
      user (connection-connattr connection :remote-home))
     ;; We are privileged, so this sets the real, effective and saved IDs.
     (nix:setgid gid) (nix:initgroups user gid) (nix:setuid uid)))
+
+(defmethod propagate-connattr
+    ((type (eql :no-services)) connattr (connection setuid-connection))
+  connattr)
diff --git a/src/deployment.lisp b/src/deployment.lisp
index 444972a..097bb9b 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -306,7 +306,11 @@ PROPERTIES, like DEPLOY-THESE."
 (defprop reconnects :posix (connections properties)
   "Connect back to the same host with CONNECTIONS and apply PROPERTIES.
 Mainly useful for using a connection type like :AS to apply properties as a
-different user."
+different user.
+
+Combinators that work by temporarily pushing hostattrs at :APPLY time will not
+be able to affect PROPERTIES in an application of RECONNECTS they enclose.
+Connection attributes, by contrast, are propagated as usual."
   (:desc (declare (ignore properties))
          (format nil "~S reconnection" connections))
   (:preprocess
diff --git a/src/package.lisp b/src/package.lisp
index 647dd5a..111be69 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -430,6 +430,7 @@
   (:local-nicknames (#:os    #:consfigurator.property.os)
                     (#:file  #:consfigurator.property.file))
   (:export #:no-services
+           #:no-services-p
            #:running
            #:restarted
            #:reloaded
@@ -719,6 +720,7 @@
   (:use #:cl #:alexandria #:consfigurator)
   (:local-nicknames (#:os        #:consfigurator.property.os)
                     (#:cmd       #:consfigurator.property.cmd)
+                    (#:service   #:consfigurator.property.service)
                     (#:file      #:consfigurator.property.file)
                     (#:chroot    #:consfigurator.property.chroot)
                     (#:apt       #:consfigurator.property.apt))
diff --git a/src/property/libvirt.lisp b/src/property/libvirt.lisp
index 330bade..e7e5009 100644
--- a/src/property/libvirt.lisp
+++ b/src/property/libvirt.lisp
@@ -98,7 +98,7 @@ subcommand of virsh(1) to convert the running domain into a transient domain."
 (I.e., if HOST is a string, ensure the domain named HOST is started; if HOST
 is a HOST value, start the libvirt domain whose name is HOST's hostname.)"
   (:desc #?"libvirt domain ${(get-hostname host)} started")
-  (:check (host-domain-started-p host))
+  (:check (or (service:no-services-p) (host-domain-started-p host)))
   (:apply (mrun "virsh" "start" (get-hostname host))))
 
 (defprop destroyed :posix (host)
diff --git a/src/property/service.lisp b/src/property/service.lisp
index bf6900c..ad920c9 100644
--- a/src/property/service.lisp
+++ b/src/property/service.lisp
@@ -18,7 +18,11 @@
 (in-package :consfigurator.property.service)
 (named-readtables:in-readtable :consfigurator)
 
-;;;; Controlling services using service(1)
+;;;; Controlling services using service(1), and the :NO-SERVICES hostattr and
+;;;; connattr.  A host has the :NO-SERVICES hostattr when it has static
+;;;; configuration never to start services.  The connattr is for when we
+;;;; should not start any services because we're doing something like
+;;;; chrooting in to the host's unbooted root filesystem.
 
 (define-constant +policyrcd+ #P"/usr/sbin/policy-rc.d" :test #'equal)
 
@@ -48,8 +52,12 @@ not affect you."
   (os:etypecase
       (debianlike (%policy-rc.d))))
 
+(defun no-services-p ()
+  "Returns true if no services should be started by the current deployment."
+  (or (get-hostattrs-car :no-service) (get-connattr :no-services)))
+
 (defun service (service action)
-  (unless (get-hostattrs-car :no-services)
+  (unless (no-services-p)
     (run :may-fail "service" service action)))
 
 (defprop running :posix (service)
@@ -72,7 +80,8 @@ properties."
   (:apply (service service "reload")))
 
 (define-function-property-combinator without-starting-services (&rest propapps)
-  "Apply PROPAPPS with SERVICE:NO-SERVICES temporarily in effect."
+  "Apply PROPAPPS with the :NO-SERVICES connattr temporarily in effect.  Also
+disable starting services by the package manager."
   (let ((propapp (if (cdr propapps) (apply #'eseqprops propapps) (car propapps))))
     (:retprop :type :lisp
               :hostattrs
@@ -88,8 +97,7 @@ properties."
                     ;; past.  (SLEEP 1) is only approximately one second so
                     ;; check that it's actually been a second.
                     (loop do (sleep 1) until (> (get-universal-time) before))
-                    (unwind-protect (with-preserve-hostattrs
-                                      (push-hostattrs :no-services t)
+                    (unwind-protect (with-connattrs (:no-services t)
                                       (propappapply propapp))
                       (if already-exists
                           ;; Check whether some property we applied set the