From 9d4655cf55ec0ab2d95b707e6b5ff009f0515bcd Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 20 Dec 2017 18:16:14 -0400
Subject: two diskimage edge case fixes

* DiskImage: Fix rsync crash when a mount point does not exist in the
  chroot.
* Fix bug in unmountBelow that caused unmounting of nested mounts to
  fail.

This commit was sponsored by Jack Hill on Patreon.
---
 src/Propellor/Property/DiskImage.hs | 19 ++++++++++++-------
 src/Propellor/Property/Mount.hs     |  4 +++-
 2 files changed, 15 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 79865db4..c9998d3c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -274,13 +274,18 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
 	desc = "partitions populated from " ++ chrootdir
 
 	go _ Nothing _ _ = noChange
-	go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
-		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
-		(const $ liftIO $ umountLazy tmpdir)
-		$ \ismounted -> if ismounted
-			then ensureProperty w $
-				syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
-			else return FailedChange
+	go w (Just mnt) mntopt loopdev = ifM (liftIO $ doesDirectoryExist srcdir) $
+		( withTmpDir "mnt" $ \tmpdir -> bracket
+			(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
+			(const $ liftIO $ umountLazy tmpdir)
+			$ \ismounted -> if ismounted
+				then ensureProperty w $
+					syncDirFiltered (filtersfor mnt) srcdir tmpdir
+				else return FailedChange
+		, return NoChange
+		)
+	  where
+		srcdir = chrootdir ++ mnt
 
 	filtersfor mnt =
 		let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index c047161d..e8f3f092 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -149,4 +149,6 @@ umountLazy mnt =
 unmountBelow :: FilePath -> IO ()
 unmountBelow d = do
 	submnts <- mountPointsBelow d
-	forM_ submnts umountLazy
+	-- sort so sub-mounts are unmounted before the mount point
+	-- containing them
+	forM_ (sort submnts) umountLazy
-- 
cgit v1.3-2-g0d8e