cache XDG_CACHE_HOME as a connattr

This should provide a performance improvement.

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

6 files changed, 45 insertions, 43 deletions

diff --git a/src/connection.lisp b/src/connection.lisp
index 782160a..9c1a291 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -227,6 +227,12 @@ login(1)).  Tilde expansion works correctly."
         (failed-change "Failed to determine remote home directory.")
         (ensure-directory-pathname (stripln home)))))
 
+(defmethod connection-connattr
+    ((connection connection) (k (eql :XDG-CACHE-HOME)))
+  (ensure-directory-pathname
+   (stripln
+    (connection-run connection "echo ${XDG_CACHE_HOME:-$HOME/.cache}" nil))))
+
 
 ;;;; Functions to access the slots of the current connection
 
@@ -556,7 +562,7 @@ specification of POSIX ls(1))."
 
 (defun remote-consfigurator-cache-pathname (path)
   (merge-pathnames
-   path (car (runlines "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/"))))
+   path (merge-pathnames "consfigurator/" (get-connattr :XDG-CACHE-HOME))))
 
 (defun readfile (path)
   (connection-readfile
diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index 2b2678c..8b144cb 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -110,26 +110,20 @@ should be the mount point, without the chroot's root prefixed.")
                (zerop (foreign-funcall "geteuid" :unsigned-int)))
     (error "~&Forking into a chroot requires a Lisp image running as root"))
   (informat 1 "~&Forking into chroot at ~A" into)
-  (let* ((into* (ensure-directory-pathname into))
-         (connection (make-instance 'shell-chroot-connection :into into*)))
-    ;; This has the side effect of populating the CONSFIGURATOR::ID and
-    ;; :REMOTE-HOME connattrs correctly, so that they don't get bogus values
-    ;; when this connection object is used in UPLOAD-ALL-PREREQUISITE-DATA.
-    (multiple-value-bind (datadir-inside exit)
-        (connection-run
-         connection
-         (format nil "echo ${XDG_CACHE_HOME:-~A/.cache}/consfigurator/data/"
-                 (connection-connattr connection :remote-home))
-         nil)
-      (unless (zerop exit)
-        (error "Failed to determine datadir inside chroot."))
-      (setq connection (change-class connection 'chroot.fork-connection))
-      (setf (slot-value connection 'datadir)
-            (ensure-pathname
-             (stripln (subseq datadir-inside 1))
-             :defaults into* :ensure-absolute t :ensure-directory t))
-      (unwind-protect (continue-connection connection remaining)
-        (connection-teardown connection)))))
+  (let* ((into (ensure-pathname into :want-absolute t :ensure-directory t))
+         (connection (make-instance 'shell-chroot-connection :into into)))
+    ;; Populate the CONSFIGURATOR::ID and :REMOTE-HOME connattrs correctly to
+    ;; ensure they don't get bogus values when this connection object is used
+    ;; in UPLOAD-ALL-PREREQUISITE-DATA.
+    (connection-connattr connection :remote-home)
+    ;; Obtain & cache XDG_CACHE_HOME inside the chroot, and compute DATADIR.
+    (let ((xdg-cache-home (connection-connattr connection :XDG-CACHE-HOME)))
+      (setf connection (change-class connection 'chroot.fork-connection)
+            (slot-value connection 'datadir)
+            (merge-pathnames
+             "consfigurator/data/" (chroot-pathname xdg-cache-home into))))
+    (unwind-protect (continue-connection connection remaining)
+      (connection-teardown connection))))
 
 (defmethod post-fork ((connection chroot.fork-connection))
   (unless (zerop (chroot (slot-value connection 'into)))
diff --git a/src/connection/local.lisp b/src/connection/local.lisp
index 745c40c..4bd272e 100644
--- a/src/connection/local.lisp
+++ b/src/connection/local.lisp
@@ -66,3 +66,8 @@ root Lisp is running on, as the root Lisp's uid."))
                                       :element-type type)
            (copy-stream-to-stream content stream :element-type type)))))
     (run-program `("mv" ,temp ,path))))
+
+(defmethod connection-connattr
+    ((connection local-connection) (k (eql :XDG-CACHE-HOME)))
+  (ensure-directory-pathname (or (getenv "XDG_CACHE_HOME")
+                                 (strcat (getenv "HOME") "/.cache"))))
diff --git a/src/connection/setuid.lisp b/src/connection/setuid.lisp
index d1df1b6..3e835e0 100644
--- a/src/connection/setuid.lisp
+++ b/src/connection/setuid.lisp
@@ -45,23 +45,22 @@
            (home
              ;; tilde expansion is POSIX
              (ensure-directory-pathname (stripln (run (strcat "echo ~" to)))))
-           (datadir
+           (xdg-cache-home
              (ensure-directory-pathname
               (stripln
                ;; su(1) is not POSIX but very likely to be present.  Note that
                ;; the -c argument here is to the user's login shell, not the
                ;; -c argument to su(1) on, e.g., FreeBSD.  So should be fairly
                ;; portable.
-               (mrun
-                "su" to "-c"
-                "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/")))))
-      (continue-connection (make-instance 'setuid-connection
-                                          :datadir datadir
-                                          :connattrs `(:remote-uid ,uid
-                                                       :remote-gid ,gid
-                                                       :remote-user ,to
-                                                       :remote-home ,home))
-                           remaining))))
+               (mrun "su" to "-c" "echo ${XDG_CACHE_HOME:-$HOME/.cache}")))))
+      (continue-connection
+       (make-instance
+        'setuid-connection
+        :datadir (merge-pathnames "consfigurator/data/" xdg-cache-home)
+        :connattrs `(:remote-uid ,uid :remote-gid ,gid
+                     :remote-user ,to :remote-home ,home
+                     :XDG-CACHE-HOME ,xdg-cache-home))
+       remaining))))
 
 (defmethod post-fork ((connection setuid-connection))
   (let ((uid (connection-connattr connection :remote-uid))
diff --git a/src/image.lisp b/src/image.lisp
index ce3a34a..8bc34b3 100644
--- a/src/image.lisp
+++ b/src/image.lisp
@@ -142,11 +142,10 @@ already running from FILENAME."
              (format nil "Dumped image to evaluate ~S" form)
              "Dumped image to execute current deployment"))
   (:apply
-   (let ((file (or filename (ensure-directories-exist
-                             (ensure-pathname
-                              (strcat (or (getenv "XDG_CACHE_HOME")
-                                          (strcat (getenv "HOME") "/.cache"))
-                                      "/consfigurator/images/latest"))))))
+   (let ((file (or filename
+                   (ensure-directories-exist
+                    (merge-pathnames "consfigurator/images/latest"
+                                     (get-connattr :XDG-CACHE-HOME))))))
      (unless (and (not always)
                   (eql :linux (uiop:operating-system))
                   (pathname-equal file (resolve-symlinks "/proc/self/exe")))
diff --git a/src/property/installer.lisp b/src/property/installer.lisp
index 2830703..38b5ce9 100644
--- a/src/property/installer.lisp
+++ b/src/property/installer.lisp
@@ -265,16 +265,15 @@ using a combinator like ON-CHANGE, or applied manually with DEPLOY-THESE."
        ;; 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/"))))
+                (merge-pathnames
+                 "consfigurator/" (get-connattr :XDG-CACHE-HOME))
                 old-os)))
          (when (directory-exists-p source)
            (rename-file source (ensure-directories-exist
                                 #P"/root/.cache/consfigurator/"))))
-       (setf (get-connattr :remote-user) "root")
-       (setf (get-connattr :remote-home) "/root")
+       (setf (get-connattr :remote-user) "root"
+             (get-connattr :remote-home) "/root"
+             (get-connattr :XDG-CACHE-HOME) #P"/root/.cache/")
        (posix-login-environment "root" "/root")
 
        ;; Remount (mainly virtual) filesystems that other properties we will