add connattrs

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

3 files changed, 75 insertions, 1 deletions

diff --git a/doc/connections.rst b/doc/connections.rst
index 5e54111..f66b207 100644
--- a/doc/connections.rst
+++ b/doc/connections.rst
@@ -44,6 +44,38 @@ connection really does require more I/O, such as in the case of
 ``:CHROOT.FORK`` connections, code can call ``LISP-CONNECTION-P``, and either
 signal an error, or fall back to another connection type.
 
+Connection attributes ("connattrs")
+-----------------------------------
+
+Information about hosts which cannot be known without looking at the host, or
+for other reasons should not be recorded in consfigs, can be stored as
+connection attributes, associated with the current connection.  Typically
+property combinators set and unset connattrs, and property ``:APPLY`` and
+``:UNAPPLY`` subroutines read them.  They can be used to create context for
+the application of properties.  Connection attributes are stored in a plist.
+Property combinators use the ``WITH-CONNATTRS`` macro to set them, and
+properties use ``GET-CONNATTR`` to read them.
+
+Like hostattrs, connection attributes are identified by keywords for connattrs
+which are expected to be used in many contexts, and by other symbols for
+connattrs which will be used only among a co-operating group of properties and
+property combinators.  However, unlike hostattrs, each connattr need not be a
+list to which new items are pushed.
+
+By default the list of connattrs is reset when establishing a new connection
+within the context of an existing connection.  However, for some connattrs it
+makes sense to propagate them along to the new connection.  For example, a
+list of connected hardware of a particular type might still be useful in the
+context of a connection which chroots, as /dev might still give access to this
+hardware.  Implementations of the ``PROPAGATE-CONNATTR`` generic function can
+be used to enable propagation where it makes sense.  Methods can copy and
+modify connattrs as appropriate; in the chroot example, paths might be updated
+so that they are relative to the new filesystem root.
+
+The propagation of connattrs is currently limited to the establishing of
+connections within the same Lisp image; i.e., connection types which start up
+new Lisp images never propagate any existing connattrs.
+
 Notes on particular connection types
 ------------------------------------
 
diff --git a/src/connection.lisp b/src/connection.lisp
index 9f71bc7..d69f157 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -83,7 +83,10 @@ For an example of usage, see the :SUDO connection type."))
    (remote-user
     :initform nil
     :documentation
-    "The name of the remote user.")))
+    "The name of the remote user.")
+   (connattrs
+    :initform nil
+    :documentation "This connection's connection attributes.")))
 
 (defclass lisp-connection (connection) ())
 
@@ -445,3 +448,38 @@ established.  Occasionally useful for testing purposes at the REPL."
      (let ((*connection* (establish-connection :sudo nil
                                                :user "root" :password nil)))
        ,@forms)))
+
+
+;;;; Connection attributes
+
+(defgeneric propagate-connattr (type connattr connection)
+  (:documentation
+   "Possibly propagate CONNATTR, a connattr identified by TYPE, through to the
+newly-established CONNECTION.  Implementations should specialise on TYPE and
+CONNECTION, not modify any of their arguments, and either return the new
+connattr, or nil if nothing should be propagated.")
+  (:method (type connattr connection)
+    "Default implementation: don't propagate."
+    nil))
+
+(defmethod initialize-instance :after ((connection connection) &key)
+  "Propagate connattrs which should be propagated."
+  (with-slots (parent) connection
+    (when (and parent (slot-boundp parent 'connattrs))
+      (doplist (k v (slot-value parent 'connattrs))
+               (when-let ((new (propagate-connattr k v connection)))
+                 (setf (getf (slot-value connection 'connattrs) k) new))))))
+
+(defun get-connattr (k)
+  "Get the connattr identified by K for the current connection."
+  (getf (slot-value *connection* 'connattrs) k))
+
+(defmacro with-connattrs ((&rest connattrs) &body forms)
+  "Execute FORMS with connattrs replaced as specified by CONNATTRS, a plist."
+  (with-gensyms (old)
+    `(with-slots (connattrs) *connection*
+       (let ((,old connattrs))
+         (setf connattrs (copy-list connattrs))
+         (doplist (k v (list ,@connattrs)) (setf (getf connattrs k) v))
+         (unwind-protect (progn ,@forms)
+           (setf connattrs ,old))))))
diff --git a/src/package.lisp b/src/package.lisp
index 3af51b1..dc3c5f0 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -113,6 +113,10 @@
            #:with-local-connection
            #:with-local-passwordless-sudo-connection
 
+           #:propagate-connattr
+           #:get-connattr
+           #:with-connattrs
+
            ;; property.lisp
            #:propattrs
            #:propunapply