From 7a67c9e3fab93f6552106d5907ef6f07e57f277b Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 24 Jun 2022 17:13:57 -0700 Subject: fix FSTAB:HAS-ENTRIES-FOR-OPENED-VOLUMES for FAT32 filesystems The property should never have been calling SUBVOLUMES-OF-TYPE because opening volumes does not ever update the VOLUME-CONTENTS slot to contain OPENED-VOLUME values. The structure of the OPENED-VOLUMES connattr is that of a flat list. Signed-off-by: Sean Whitton --- src/connection/chroot.lisp | 13 +++++++-- src/package.lisp | 1 + src/property/disk.lisp | 68 ++++++++++++++++++++++++++++------------------ src/property/fstab.lisp | 18 ++++-------- 4 files changed, 58 insertions(+), 42 deletions(-) diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp index 854043e..a4a67d3 100644 --- a/src/connection/chroot.lisp +++ b/src/connection/chroot.lisp @@ -67,10 +67,9 @@ should be the mount point, without the chroot's root prefixed.") (when (remote-exists-p "/sys/firmware/efi/efivars") (apply #'chroot-mount connection mount:+linux-efivars-vfs+))))) -(defmethod propagate-connattr - ((type (eql 'disk:opened-volumes)) connattr (connection chroot-connection)) +(defun copy-and-update-volumes (volumes connection) (with-slots (into) connection - (loop for volume in connattr + (loop for volume in volumes when (and (subtypep (type-of volume) 'disk:filesystem) (slot-boundp volume 'disk:mount-point) (subpathp (disk:mount-point volume) into)) @@ -79,6 +78,14 @@ should be the mount point, without the chroot's root prefixed.") (in-chroot-pathname (disk:mount-point it) into))) else collect volume))) +(defmethod propagate-connattr + ((type (eql 'disk:opened-volumes)) connattr (connection chroot-connection)) + (copy-and-update-volumes connattr connection)) + +(defmethod propagate-connattr + ((type (eql 'disk:opened-volume-parents)) connattr (connection chroot-connection)) + (copy-and-update-volumes connattr connection)) + (defmethod propagate-connattr ((type (eql :remote-uid)) connattr (connection chroot-connection)) connattr) diff --git a/src/package.lisp b/src/package.lisp index c65b04b..241af89 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -645,6 +645,7 @@ #:linux-swap #:opened-volumes + #:opened-volume-parents #:with-opened-volumes #:has-volumes diff --git a/src/property/disk.lisp b/src/property/disk.lisp index ac55e9e..7f9c949 100644 --- a/src/property/disk.lisp +++ b/src/property/disk.lisp @@ -663,37 +663,49 @@ explicitly request one." "Where each of VOLUMES is a VOLUME which may be opened by calling OPEN-VOLUME with NIL as the second argument, recursively open each of VOLUMES and any contents thereof, and return a list of the volumes that were opened, in the -order in which they should be closed. MOUNT-BELOW specifies a pathname to -prefix to mount points when opening FILESYSTEM volumes. +order in which they should be closed, and as a second value, a corresponding +list of the immediate parents of each opened volume. MOUNT-BELOW specifies a +pathname to prefix to mount points when opening FILESYSTEM volumes. Calling this function can be useful for testing at the REPL, but code should normally use WITH-OPEN-VOLUMES or WITH-OPENED-VOLUMES. If an error is signalled while the attempt to open volumes is in progress, a single attempt will be made to close all volumes opened up to that point." - (let (opened-volumes filesystems) + (let (opened-volumes all-parents filesystems *latest-parent*) + (declare (special *latest-parent*)) (handler-case (labels ((open-volume-and-contents (volume file) ;; Postpone filesystems until the end so that we can sort ;; them before mounting, to avoid unintended shadowing. (if (subtypep (type-of volume) 'filesystem) - (push (list volume file) filesystems) + (push (list *latest-parent* volume file) filesystems) (multiple-value-bind (opened opened-contents) (open-volume volume file) - (setq opened-volumes - (append - opened-contents - ;; Don't queue for closure volumes which were - ;; already open before we began. - (if (subtypep (class-of volume) 'opened-volume) - opened-volumes - (cons opened opened-volumes)))) + (let ((opened-contents-parents + (make-list (length opened-contents) + :initial-element volume))) + ;; Don't queue for closure volumes which were already + ;; open before we began. + (if (subtypep (class-of volume) 'opened-volume) + (setq opened-volumes + (append opened-contents opened-volumes) + all-parents + (nconc opened-contents-parents all-parents)) + (setq opened-volumes + (append opened-contents + (cons opened opened-volumes)) + all-parents + (nconc opened-contents-parents + (cons *latest-parent* all-parents))))) (dolist (opened-volume (or opened-contents `(,opened))) (when (slot-boundp opened-volume 'volume-contents) - (open-volume-and-contents - (volume-contents opened-volume) - (device-file opened-volume)))))))) + (let ((*latest-parent* opened-volume)) + (declare (special *latest-parent*)) + (open-volume-and-contents + (volume-contents opened-volume) + (device-file opened-volume))))))))) (mapc (rcurry #'open-volume-and-contents nil) volumes) ;; Note that filesystems never have any VOLUME-CONTENTS to open. (with-mount-below @@ -702,9 +714,10 @@ single attempt will be made to close all volumes opened up to that point." (sort filesystems #'subpathp :key (compose #'ensure-directory-pathname #'mount-point - #'car)))) + #'cadr)))) + (push (pop filesystem) all-parents) (push (apply #'open-volume filesystem) opened-volumes))) - opened-volumes) + (values opened-volumes all-parents)) (serious-condition (condition) (unwind-protect (mapc #'close-volume opened-volumes) (error condition)))))) @@ -740,8 +753,9 @@ volumes that were opened. MOUNT-BELOW specifies a pathname to prefix to mount points when opening FILESYSTEM volumes. During the application of PROPAPPS, all -'DISK:OPENED-VOLUMES connattrs are replaced with a list of the volumes that -were opened; this list must not be modified." +'DISK:OPENED-VOLUMES and 'DISK:OPENED-VOLUME-PARENTS connattrs are replaced +with lists of the volumes that were opened and corresponding immediate parent +volumes; the former must not be modified." `(with-opened-volumes* ',volumes ,(if (cdr propapps) `(eseqprops ,@propapps) (car propapps)) @@ -756,13 +770,15 @@ were opened; this list must not be modified." (propapp-attrs propapp)) :apply (lambda-ignoring-args - (with-connattrs ('opened-volumes - (apply #'open-volumes-and-contents - `(,volumes ,@(and mount-below-supplied-p - `(:mount-below ,mount-below))))) - (unwind-protect (apply-propapp propapp) - (mrun "sync") - (mapc #'close-volume (get-connattr 'opened-volumes))))) + (multiple-value-bind (opened-volumes parents) + (apply #'open-volumes-and-contents + `(,volumes ,@(and mount-below-supplied-p + `(:mount-below ,mount-below)))) + (with-connattrs ('opened-volumes opened-volumes + 'opened-volume-parents parents) + (unwind-protect (apply-propapp propapp) + (mrun "sync") + (mapc #'close-volume (get-connattr 'opened-volumes)))))) :args (cdr propapp))) (defun create-volumes-and-contents (volumes &optional files) diff --git a/src/property/fstab.lisp b/src/property/fstab.lisp index 836cc1c..0c88d8e 100644 --- a/src/property/fstab.lisp +++ b/src/property/fstab.lisp @@ -101,22 +101,14 @@ specified with DISK:HAS-VOLUMES." (curry #'subvolumes-of-type 'filesystem) (or volumes (get-hostattrs :volumes)))))))) -;; TODO This is broken for fat32 partitions. MOUNTED-FAT32-FILESYSTEM objects -;; are pushed directly to the connattr by DISK:WITH-OPENED-VOLUMES, rather -;; than appearing within OPENED-PARTITION objects. Then the call to -;; SUBVOLUMES-OF-TYPE here never finds any parents, returning as a second -;; value a list containing only NIL. Thus the specialisers in the -;; implementation of FS-SPEC for MOUNTED-FAT32-FILESYSTEM are never satisfied. (defprop has-entries-for-opened-volumes :posix () "Add or update entries in /etc/fstab for currently open volumes. This is used when building disk images and installing operating systems." (:desc "fstab entries for opened volumes") (:hostattrs (os:required 'os:linux)) - (:apply - (apply #'has-entries - (apply #'mapcar #'volume-to-entry - (multiple-value-list - (multiple-value-mapcan - (curry #'subvolumes-of-type 'mounted-filesystem) - (get-connattr 'disk:opened-volumes))))))) + (:apply (loop for volume in (get-connattr 'disk:opened-volumes) + and parent in (get-connattr 'disk:opened-volume-parents) + when (subtypep (type-of volume) 'disk:filesystem) + collect (volume-to-entry volume parent) into entries + finally (apply #'has-entries entries)))) -- cgit v1.2.3