MOUNT:UNMOUNTED-BELOW-AND-REMOVED: don't unmount DIR itself

If DIR is itself a mount point then previously we would never delete its
contents because the unmounting is done first.  This meant that when
MOUNT:UNMOUNTED-BELOW-AND-REMOVED was used to remove the root filesystem of a
container or virtual machine, for example, then whether the contents of the
root filesystem was actually deleted depended upon whether DIR happened to be
a mount point.  This change ensures that the deletion is always done.

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

1 files changed, 12 insertions, 6 deletions

diff --git a/src/property/mount.lisp b/src/property/mount.lisp
index c00ed23..f4a06ed 100644
--- a/src/property/mount.lisp
+++ b/src/property/mount.lisp
@@ -76,12 +76,18 @@ this property will empty /dev, breaking all kinds of things."
            do (loop while (subpathp (car sorted) next) do (pop sorted))
               (mrun "umount" "--recursive" next)))))
 
-(defproplist unmounted-below-and-removed :posix (dir)
-  "Unmount anything mounted at or below DIR and recursively delete dir."
-  (:desc #?"${dir} unmounted and removed")
-  (:check (not (remote-exists-p dir)))
-  (unmounted-below dir)
-  (cmd:single "rm" "-rf" dir))
+(defprop unmounted-below-and-removed :posix (dir)
+  "Unmount anything mounted below DIR, recursively delete the contents of DIR,
+and unless DIR is itself a mount point, also remove DIR."
+  (:desc #?"${dir} unmounted below and emptied/removed")
+  (:hostattrs (os:required 'os:linux))
+  (:check (or (not (remote-exists-p dir))
+              (and (mountpointp dir)
+                   (null (runlines "find" dir "-not" "-path" dir)))))
+  (:apply (ignoring-hostattrs (unmounted-below dir :and-at nil))
+          (if (mountpointp dir)
+              (empty-remote-directory dir)
+              (delete-remote-trees dir))))
 
 (defun all-mounts (&optional (below #P"/"))
   "Retrieve all mountpoints below BELOW, ordered lexicographically.