From 1f12dfda4aeb6d08af454d60caa5985b2bd5b1ba Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sat, 28 Aug 2021 15:54:18 -0700 Subject: cache XDG_CACHE_HOME as a connattr This should provide a performance improvement. Signed-off-by: Sean Whitton --- src/connection.lisp | 8 +++++++- src/connection/chroot.lisp | 34 ++++++++++++++-------------------- src/connection/local.lisp | 5 +++++ src/connection/setuid.lisp | 21 ++++++++++----------- src/image.lisp | 9 ++++----- src/property/installer.lisp | 11 +++++------ 6 files changed, 45 insertions(+), 43 deletions(-) (limited to 'src') 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 -- cgit v1.2.3