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 <spwhitton@spwhitton.name>

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))
@@ -80,6 +79,14 @@ should be the mount point, without the chroot's root prefixed.")
           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))))