Property.Partition: Update kpartx output parser, as its output format changed around version 0.6. Both output formats are supported now.

Do we trust kpartx to not change again, given how little documented its
output format is and that it's changed w/o warning? Little other things
like vmdebootstrap depend on its output in the same way..

This commit was sponsored by Ignacio on Patreon.

1 files changed, 21 insertions, 5 deletions

diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 756e2b6b..679675b7 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -9,6 +9,7 @@ import Utility.Applicative
 
 import System.Posix.Files
 import Data.List
+import Data.Char
 
 -- | Filesystems etc that can be used for a partition.
 data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
@@ -58,7 +59,7 @@ isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev
 isLoopDev' :: FilePath -> IO Bool
 isLoopDev' f
 	| "loop" `isInfixOf` f = catchBoolIO $
-		isBlockDevice <$> getSymbolicLinkStatus f
+		isBlockDevice <$> getFileStatus f
 	| otherwise = return False
 
 -- | Uses the kpartx utility to create device maps for partitions contained
@@ -81,11 +82,26 @@ kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
 		return r
 	cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
 
+-- kpartx's output includes the device for the loop partition, and some
+-- information about the whole disk loop device. In earlier versions,
+-- this was simply the path to the loop device. But, in kpartx 0.6,
+-- this changed to the major:minor of the block device. Either is handled
+-- by this parser. 
 kpartxParse :: String -> [LoopDev]
 kpartxParse = mapMaybe (finddev . words) . lines
   where
-	finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev 
-		{ partitionLoopDev = "/dev/mapper/" ++ ld
-		, wholeDiskLoopDev = wd
-		}
+	finddev ("add":"map":ld:_:_:_:_:s:_) = do
+		wd <- if isAbsolute s
+			then Just s
+			-- A loop partition name loop0pn corresponds to
+			-- /dev/loop0. It would be more robust to check
+			-- that the major:minor matches, but haskell's
+			-- unix library lacks a way to do that.
+			else case takeWhile isDigit (dropWhile (not . isDigit) ld) of
+				[] -> Nothing
+				n -> Just $ "/dev" </> "loop" ++ n
+		Just $ LoopDev
+			{ partitionLoopDev = "/dev/mapper/" ++ ld
+			, wholeDiskLoopDev = wd
+			}
 	finddev _ = Nothing