From 6399d6d2722320346877071866414e450701fbf9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 22 Oct 2015 16:23:24 -0400
Subject: propellor spin

---
 src/Propellor/Property/Partition.hs | 23 +++++++++++++++++------
 1 file changed, 17 insertions(+), 6 deletions(-)

(limited to 'src/Propellor/Property/Partition.hs')

diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 56bc1575..fa381d5d 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -41,20 +41,31 @@ formatted' opts YesReallyFormatPartition fs dev =
 	-- Be quiet.
 	q l = "-q":l
 
+data LoopDev = LoopDev
+	{ partitionLoopDev :: FilePath -- ^ device for a loop partition
+	, wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
+	} deriving (Show)
+
 -- | Uses the kpartx utility to create device maps for partitions contained
--- within a disk image file. The resulting devices are passed to the
+-- within a disk image file. The resulting loop devices are passed to the
 -- property, which can operate on them. Always cleans up after itself,
 -- by removing the device maps after the property is run.
-kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo
+kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo
 kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
   where
 	go = property (propertyDesc (mkprop [])) $ do
 		cleanup -- idempotency
 		s <- liftIO $ readProcess "kpartx" ["-avs", diskimage]
-		r <- ensureProperty (mkprop (devlist s))
+		r <- ensureProperty (mkprop (kpartxParse s))
 		cleanup
 		return r
-	devlist = mapMaybe (finddev . words) . lines
-	finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s)
-	finddev _ = Nothing
 	cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
+
+kpartxParse :: String -> [LoopDev]
+kpartxParse = mapMaybe (finddev . words) . lines
+  where
+	finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev 
+		{ partitionLoopDev = "/dev/mapper/" ++ ld
+		, wholeDiskLoopDev = wd
+		}
+	finddev _ = Nothing
-- 
cgit v1.3-2-g0d8e


From 9c1630d3c17b495ce97dfff5bd4a94c98c5b46db Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 22 Oct 2015 18:59:16 -0400
Subject: belt-and-suspenders check of kpartx output

---
 src/Propellor/Property/Partition.hs | 21 +++++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

(limited to 'src/Propellor/Property/Partition.hs')

diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index fa381d5d..fd3c7930 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -4,6 +4,10 @@ module Propellor.Property.Partition where
 
 import Propellor.Base
 import qualified Propellor.Property.Apt as Apt
+import Utility.Applicative
+
+import System.Posix.Files
+import Data.List
 
 -- | Filesystems etc that can be used for a partition.
 data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
@@ -46,6 +50,15 @@ data LoopDev = LoopDev
 	, wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
 	} deriving (Show)
 
+isLoopDev :: LoopDev -> IO Bool
+isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev l)
+
+isLoopDev' :: FilePath -> IO Bool
+isLoopDev' f
+	| "loop" `isInfixOf` f = catchBoolIO $
+		isBlockDevice <$> getFileStatus f
+	| otherwise = return False
+
 -- | Uses the kpartx utility to create device maps for partitions contained
 -- within a disk image file. The resulting loop devices are passed to the
 -- property, which can operate on them. Always cleans up after itself,
@@ -55,8 +68,12 @@ kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
   where
 	go = property (propertyDesc (mkprop [])) $ do
 		cleanup -- idempotency
-		s <- liftIO $ readProcess "kpartx" ["-avs", diskimage]
-		r <- ensureProperty (mkprop (kpartxParse s))
+		loopdevs <- liftIO $ kpartxParse
+			<$> readProcess "kpartx" ["-avs", diskimage]
+		bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
+		unless (null bad) $
+			error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
+		r <- ensureProperty (mkprop loopdevs)
 		cleanup
 		return r
 	cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
-- 
cgit v1.3-2-g0d8e