cache XDG_CACHE_HOME as a connattr

This should provide a performance improvement.

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

3 files changed, 29 insertions, 31 deletions

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))