propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

DiskImage.hs (19896B)


      1 -- | Disk image generation.
      2 --
      3 -- This module is designed to be imported unqualified.
      4 
      5 {-# LANGUAGE TypeFamilies #-}
      6 
      7 module Propellor.Property.DiskImage (
      8 	-- * Partition specification
      9 	module Propellor.Property.DiskImage.PartSpec,
     10 	-- * Properties
     11 	DiskImage(..),
     12 	RawDiskImage(..),
     13 	VirtualBoxPointer(..),
     14 	imageBuilt,
     15 	imageRebuilt,
     16 	imageBuiltFor,
     17 	imageRebuiltFor,
     18 	imageBuiltFrom,
     19 	imageExists,
     20 	imageChrootNotPresent,
     21 	GrubTarget(..),
     22 	noBootloader,
     23 ) where
     24 
     25 import Propellor.Base
     26 import Propellor.Property.DiskImage.PartSpec
     27 import Propellor.Property.Chroot (Chroot)
     28 import Propellor.Property.Chroot.Util (removeChroot)
     29 import Propellor.Property.Mount
     30 import qualified Propellor.Property.Chroot as Chroot
     31 import qualified Propellor.Property.Service as Service
     32 import qualified Propellor.Property.Grub as Grub
     33 import qualified Propellor.Property.File as File
     34 import qualified Propellor.Property.Apt as Apt
     35 import qualified Propellor.Property.Qemu as Qemu
     36 import qualified Propellor.Property.FlashKernel as FlashKernel
     37 import Propellor.Property.Parted
     38 import Propellor.Property.Fstab (SwapPartition(..), genFstab)
     39 import Propellor.Property.Partition
     40 import Propellor.Property.Rsync
     41 import Propellor.Types.Info
     42 import Propellor.Types.Bootloader
     43 import Propellor.Container
     44 import Utility.Path
     45 import Utility.DataUnits
     46 
     47 import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4)
     48 import Data.Function (on)
     49 import qualified Data.Map.Strict as M
     50 import qualified Data.ByteString.Lazy as L
     51 import System.Posix.Files
     52 
     53 -- | Type class of disk image formats.
     54 class DiskImage d where
     55 	-- | Get the location where the raw disk image should be stored.
     56 	rawDiskImage :: d -> RawDiskImage
     57 	-- | Describe the disk image (for display to the user)
     58 	describeDiskImage :: d -> String
     59 	-- | Convert the raw disk image file in the
     60 	-- `rawDiskImage` location into the desired disk image format.
     61 	-- For best efficiency, the raw disk imasge file should be left
     62 	-- unchanged on disk.
     63 	buildDiskImage :: d -> RevertableProperty DebianLike Linux
     64 
     65 -- | A raw disk image, that can be written directly out to a disk.
     66 newtype RawDiskImage = RawDiskImage FilePath
     67 
     68 instance DiskImage RawDiskImage where
     69 	rawDiskImage = id
     70 	describeDiskImage (RawDiskImage f) = f
     71 	buildDiskImage (RawDiskImage _) = doNothing <!> doNothing
     72 
     73 -- | A virtualbox .vmdk file, which contains a pointer to the raw disk
     74 -- image. This can be built very quickly.
     75 newtype VirtualBoxPointer = VirtualBoxPointer FilePath
     76 
     77 instance DiskImage VirtualBoxPointer where
     78 	rawDiskImage (VirtualBoxPointer f) = RawDiskImage $
     79 		dropExtension f ++ ".img"
     80 	describeDiskImage (VirtualBoxPointer f) = f
     81 	buildDiskImage (VirtualBoxPointer vmdkfile) = (setup <!> cleanup)
     82 		`describe` (vmdkfile ++ " built")
     83 	  where
     84 		setup = cmdProperty "VBoxManage"
     85 			[ "internalcommands", "createrawvmdk"
     86 			, "-filename", vmdkfile
     87 			, "-rawdisk", diskimage
     88 			]
     89 			`changesFile` vmdkfile
     90 			`onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes))
     91 			`requires` Apt.installed ["virtualbox"]
     92 			`requires` File.notPresent vmdkfile
     93 		cleanup = tightenTargets $ File.notPresent vmdkfile
     94 		RawDiskImage diskimage = rawDiskImage (VirtualBoxPointer vmdkfile)
     95 
     96 -- | Creates a bootable disk image.
     97 --
     98 -- First the specified Chroot is set up, and its properties are satisfied.
     99 --
    100 -- Then, the disk image is set up, and the chroot is copied into the
    101 -- appropriate partition(s) of it. 
    102 --
    103 -- The partitions default to being sized just large enough to fit the files
    104 -- from the chroot. You can use `addFreeSpace` to make them a bit larger
    105 -- than that, or `setSize` to use a fixed size.
    106 -- 
    107 -- Note that the disk image file is reused if it already exists,
    108 -- to avoid expensive IO to generate a new one. And, it's updated in-place,
    109 -- so its contents are undefined during the build process.
    110 --
    111 -- Note that the `Service.noServices` property is automatically added to the
    112 -- chroot while the disk image is being built, which should prevent any
    113 -- daemons that are included from being started on the system that is
    114 -- building the disk image.
    115 --
    116 -- Example use:
    117 --
    118 -- > import Propellor.Property.DiskImage
    119 -- > import Propellor.Property.Chroot
    120 -- > 
    121 -- > foo = host "foo.example.com" $ props
    122 -- > 	& imageBuilt (RawDiskImage "/srv/diskimages/disk.img") mychroot
    123 -- >		MSDOS
    124 -- >		[ partition EXT2 `mountedAt` "/boot"
    125 -- >			`setFlag` BootFlag
    126 -- >		, partition EXT4 `mountedAt` "/"
    127 -- >			`addFreeSpace` MegaBytes 100
    128 -- >			`mountOpt` errorReadonly
    129 -- >		, swapPartition (MegaBytes 256)
    130 -- >		]
    131 -- >  where
    132 -- >	mychroot d = debootstrapped mempty d $ props
    133 -- >		& osDebian Unstable X86_64
    134 -- >		& Apt.installed ["linux-image-amd64"]
    135 -- >		& Grub.installed PC
    136 -- >		& User.hasPassword (User "root")
    137 -- >		& User.accountFor (User "demo")
    138 -- > 		& User.hasPassword (User "demo")
    139 -- >		& User.hasDesktopGroups (User "demo")
    140 -- > 		& ...
    141 imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
    142 imageBuilt = imageBuilt' False
    143 
    144 -- | Like 'imageBuilt', but the chroot is deleted and rebuilt from scratch
    145 -- each time. This is more expensive, but useful to ensure reproducible
    146 -- results when the properties of the chroot have been changed.
    147 imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
    148 imageRebuilt = imageBuilt' True
    149 
    150 -- | Create a bootable disk image for a Host.
    151 --
    152 -- This works just like 'imageBuilt', but partition table is
    153 -- determined by looking at the Host's 'hasPartitionTableType',
    154 -- `hasPartition', and 'adjustPartition' properties.
    155 --
    156 -- For example:
    157 --
    158 -- > foo :: Host
    159 -- > foo = host "foo.example.com" $ props
    160 -- >	& imageBuiltFor bar
    161 -- >		(RawDiskImage "/srv/diskimages/bar-disk.img")
    162 -- >		(Debootstrapped mempty)
    163 -- >
    164 -- > bar :: Host
    165 -- > bar = host "bar.example.com" $ props
    166 -- >	& hasPartiton
    167 -- >		( partition EXT2
    168 -- >		`mountedAt` "/boot"
    169 -- >		`partLocation` Beginning
    170 -- >		`addFreeSpace` MegaBytes 150
    171 -- >		)
    172 -- >	& hasPartiton
    173 -- >		( partition EXT4
    174 -- >		`mountedAt` "/"
    175 -- >		`addFreeSpace` MegaBytes 500
    176 -- >		)
    177 -- >	& osDebian Unstable X86_64
    178 -- >	& Apt.installed ["linux-image-amd64"]
    179 -- >	& Grub.installed PC
    180 -- >	& hasPassword (User "root")
    181 imageBuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux
    182 imageBuiltFor = imageBuiltFor' False
    183 
    184 -- | Like 'imageBuiltFor', but the chroot is deleted and rebuilt from
    185 -- scratch each time.
    186 imageRebuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux
    187 imageRebuiltFor = imageBuiltFor' False
    188 
    189 imageBuiltFor' :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Bool -> Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux
    190 imageBuiltFor' rebuild h d bs =
    191 	imageBuilt' rebuild d (Chroot.hostChroot h bs) tt pil
    192   where
    193 	PartTableSpec tt pil = toPartTableSpec (fromInfo (hostInfo h))
    194 
    195 imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
    196 imageBuilt' rebuild img mkchroot tabletype partspec =
    197 	imageBuiltFrom img chrootdir tabletype final partspec
    198 		`requires` Chroot.provisioned chroot
    199 		`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
    200 		`describe` desc
    201   where
    202 	desc = "built disk image " ++ describeDiskImage img
    203 	cleanrebuild :: Property Linux
    204 	cleanrebuild
    205 		| rebuild = property desc $ do
    206 			liftIO $ removeChroot chrootdir
    207 			return MadeChange
    208 		| otherwise = doNothing
    209 	chrootdir = imageChroot img
    210 	chroot =
    211 		let c = propprivdataonly $ mkchroot chrootdir
    212 		in setContainerProps c $ containerProps c
    213 			-- Before ensuring any other properties of the chroot,
    214 			-- avoid starting services. Reverted by imageFinalized.
    215 			&^ Service.noServices
    216 			& cachesCleaned
    217 	-- Only propagate privdata Info from this chroot, nothing else.
    218 	propprivdataonly (Chroot.Chroot d b ip h) =
    219 		Chroot.Chroot d b (\c _ -> ip c onlyPrivData) h
    220 	-- Pick boot loader finalization based on which bootloader is
    221 	-- installed.
    222 	final = case fromInfo (containerInfo chroot) of
    223 		[] -> unbootable "no bootloader is installed"
    224 		[GrubInstalled grubtarget] -> grubFinalized grubtarget
    225 		[UbootInstalled p] -> ubootFinalized p
    226 		[FlashKernelInstalled] -> flashKernelFinalized
    227 		[UbootInstalled p, FlashKernelInstalled] -> 
    228 			ubootFlashKernelFinalized p
    229 		[FlashKernelInstalled, UbootInstalled p] -> 
    230 			ubootFlashKernelFinalized p
    231 		[NoBootloader] -> noBootloaderFinalized
    232 		_ -> unbootable "multiple bootloaders are installed; don't know which to use"
    233 
    234 -- | This property is automatically added to the chroot when building a
    235 -- disk image. It cleans any caches of information that can be omitted;
    236 -- eg the apt cache on Debian.
    237 cachesCleaned :: Property UnixLike
    238 cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
    239   where
    240 	skipit = doNothing :: Property UnixLike
    241 
    242 -- | Builds a disk image from the contents of a chroot.
    243 imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
    244 imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
    245   where
    246 	desc = describeDiskImage img ++ " built from " ++ chrootdir
    247 	dest@(RawDiskImage imgfile) = rawDiskImage img
    248 	mkimg = property' desc $ \w -> do
    249 		-- Unmount helper filesystems such as proc from the chroot
    250 		-- first; don't want to include the contents of those.
    251 		liftIO $ unmountBelow chrootdir
    252 		szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
    253 			<$> liftIO (dirSizes chrootdir)
    254 		let calcsz mnts = maybe defSz fudgeSz . getMountSz szm mnts
    255 		-- tie the knot!
    256 		let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
    257 			map (calcsz mnts) mnts
    258 		ensureProperty w $
    259 			imageExists' dest parttable
    260 				`before`
    261 			kpartx imgfile (mkimg' mnts mntopts parttable)
    262 				`before`
    263 			buildDiskImage img
    264 	mkimg' mnts mntopts parttable devs =
    265 		partitionsPopulated chrootdir mnts mntopts devs
    266 			`before`
    267 		imageFinalized final dest mnts mntopts devs parttable
    268 	rmimg = undoRevertableProperty (buildDiskImage img)
    269 		`before` undoRevertableProperty (imageExists' dest dummyparttable)
    270 	dummyparttable = PartTable tabletype safeAlignment []
    271 
    272 partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
    273 partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
    274 	mconcat $ zipWith3 (go w) mnts mntopts devs
    275   where
    276 	desc = "partitions populated from " ++ chrootdir
    277 
    278 	go _ Nothing _ _ = noChange
    279 	go w (Just mnt) mntopt loopdev = ifM (liftIO $ doesDirectoryExist srcdir) $
    280 		( withTmpDir "mnt" $ \tmpdir -> bracket
    281 			(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
    282 			(const $ liftIO $ umountLazy tmpdir)
    283 			$ \ismounted -> if ismounted
    284 				then ensureProperty w $
    285 					syncDirFiltered (filtersfor mnt) srcdir tmpdir
    286 				else return FailedChange
    287 		, return NoChange
    288 		)
    289 	  where
    290 		srcdir = chrootdir ++ mnt
    291 
    292 	filtersfor mnt =
    293 		let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
    294 			filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m)
    295 				(catMaybes mnts)
    296 		in concatMap (\m ->
    297 			-- Include the child mount point, but exclude its contents.
    298 			[ Include (Pattern m)
    299 			, Exclude (filesUnder m)
    300 			-- Preserve any lost+found directory that mkfs made
    301 			, Protect (Pattern "lost+found")
    302 			]) childmnts
    303 
    304 -- The constructor for each Partition is passed the size of the files
    305 -- from the chroot that will be put in that partition.
    306 fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
    307 fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
    308   where
    309 	(mounts, mountopts, sizers, _) = unzip4 l
    310 	parttable = PartTable tt safeAlignment (zipWith id sizers basesizes)
    311 
    312 -- | Generates a map of the sizes of the contents of
    313 -- every directory in a filesystem tree.
    314 --
    315 -- (Hard links are counted multiple times for simplicity)
    316 --
    317 -- Should be same values as du -bl
    318 dirSizes :: FilePath -> IO (M.Map FilePath Integer)
    319 dirSizes top = go M.empty top [top]
    320   where
    321 	go m _ [] = return m
    322 	go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do
    323 		s <- getSymbolicLinkStatus i
    324 		let sz = fromIntegral (fileSize s)
    325 		if isDirectory s
    326 			then do
    327 				subm <- go M.empty i =<< dirContents i
    328 				let sz' = M.foldr' (+) sz
    329 					(M.filterWithKey (const . subdirof i) subm)
    330 				go (M.insertWith (+) i sz' (M.union m subm)) dir is
    331 			else go (M.insertWith (+) dir sz m) dir is
    332 	subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
    333 
    334 getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
    335 getMountSz _ _ Nothing = Nothing
    336 getMountSz szm l (Just mntpt) =
    337 	fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
    338   where
    339 	childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
    340 
    341 -- | Ensures that a disk image file of the specified size exists.
    342 --
    343 -- If the file doesn't exist, or is too small, creates a new one, full of 0's.
    344 --
    345 -- If the file is too large, truncates it down to the specified size.
    346 imageExists :: RawDiskImage -> ByteSize -> Property Linux
    347 imageExists (RawDiskImage img) isz = property ("disk image exists" ++ img) $ liftIO $ do
    348 	ms <- catchMaybeIO $ getFileStatus img
    349 	case fmap (toInteger . fileSize) ms of
    350 		Just s
    351 			| s == toInteger sz -> return NoChange
    352 			| s > toInteger sz -> do
    353 				infoMessage ["truncating " ++ img ++ " to " ++ humansz]
    354 				setFileSize img (fromInteger sz)
    355 				return MadeChange
    356 			| otherwise -> do
    357 				infoMessage ["expanding " ++ img ++ " from " ++ roughSize storageUnits False s ++ " to " ++ humansz]
    358 				L.writeFile img (L.replicate (fromIntegral sz) 0)
    359 				return MadeChange
    360 		Nothing -> do
    361 			infoMessage ["creating " ++ img ++ " of size " ++ humansz]
    362 			L.writeFile img (L.replicate (fromIntegral sz) 0)
    363 			return MadeChange
    364   where
    365 	sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize
    366 	humansz = roughSize storageUnits False (toInteger sz)
    367 	-- Disks have a sector size, and making a disk image not
    368 	-- aligned to a sector size will confuse some programs.
    369 	-- Common sector sizes are 512 and 4096; use 4096 as it's larger.
    370 	sectorsize = 4096 :: Double
    371 
    372 -- | Ensure that disk image file exists and is partitioned.
    373 --
    374 -- Avoids repartitioning the disk image, when a file of the right size
    375 -- already exists, and it has the same PartTable.
    376 imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
    377 imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc
    378   where
    379 	desc = "disk image exists " ++ img
    380 	parttablefile = imageParttableFile dest
    381 	setup = property' desc $ \w -> do
    382 		oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
    383 		res <- ensureProperty w $ imageExists dest (partTableSize parttable)
    384 		if res == NoChange && oldparttable == show parttable
    385 			then return NoChange
    386 			else if res == FailedChange
    387 				then return FailedChange
    388 				else do
    389 					liftIO $ writeFile parttablefile (show parttable)
    390 					ensureProperty w $ partitioned YesReallyDeleteDiskContents img parttable
    391 	cleanup = File.notPresent img
    392 		`before`
    393 		File.notPresent parttablefile
    394 
    395 -- | A property that is run after the disk image is created, with
    396 -- its populated partition tree mounted in the provided
    397 -- location from the provided loop devices. This is typically used to
    398 -- install a boot loader in the image's superblock.
    399 --
    400 -- It's ok if the property leaves additional things mounted
    401 -- in the partition tree.
    402 type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux)
    403 
    404 imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
    405 imageFinalized final img mnts mntopts devs (PartTable _ _ parts) =
    406 	property' "disk image finalized" $ \w ->
    407 		withTmpDir "mnt" $ \top ->
    408 			go w top `finally` liftIO (unmountall top)
    409   where
    410 	go w top = do
    411 		liftIO $ mountall top
    412 		liftIO $ writefstab top
    413 		liftIO $ allowservices top
    414 		ensureProperty w $ 
    415 			final img top devs
    416 				`before` Qemu.removeHostEmulationBinary top
    417 
    418 	-- Ordered lexographically by mount point, so / comes before /usr
    419 	-- comes before /usr/local
    420 	orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
    421 	orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs)
    422 
    423 	swaps = map (SwapPartition . partitionLoopDev . snd) $
    424 		filter ((== Just LinuxSwap) . partFs . fst) $
    425 			zip parts devs
    426 
    427 	mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of
    428 		Nothing -> noop
    429 		Just p -> do
    430 			let mnt = top ++ p
    431 			createDirectoryIfMissing True mnt
    432 			unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $
    433 				error $ "failed mounting " ++ mnt
    434 
    435 	unmountall top = do
    436 		unmountBelow top
    437 		umountLazy top
    438 
    439 	writefstab top = do
    440 		let fstab = top ++ "/etc/fstab"
    441 		old <- catchDefaultIO [] $ filter (not . unconfigured) . lines
    442 			<$> readFileStrict fstab
    443 		new <- genFstab (map (top ++) (catMaybes mnts))
    444 			swaps (toSysDir top)
    445 		writeFile fstab $ unlines $ new ++ old
    446 	-- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM"
    447 	unconfigured s = "UNCONFIGURED" `isInfixOf` s
    448 
    449 	allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
    450 
    451 unbootable :: String -> Finalization
    452 unbootable msg = \_ _ _ -> property desc $ do
    453 	warningMessage (desc ++ ": " ++ msg)
    454 	return FailedChange
    455   where
    456 	desc = "image is not bootable"
    457 
    458 grubFinalized :: GrubTarget -> Finalization
    459 grubFinalized grubtarget _img mnt loopdevs = 
    460 	Grub.bootsMounted mnt wholediskloopdev grubtarget
    461 		`describe` "disk image boots using grub"
    462   where
    463 	-- It doesn't matter which loopdev we use; all
    464 	-- come from the same disk image, and it's the loop dev
    465 	-- for the whole disk image we seek.
    466 	wholediskloopdev = case loopdevs of
    467 		(l:_) -> wholeDiskLoopDev l
    468 		[] -> error "No loop devs provided!"
    469 
    470 ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
    471 ubootFinalized p (RawDiskImage img) mnt _loopdevs = p img mnt
    472 
    473 flashKernelFinalized :: Finalization
    474 flashKernelFinalized _img mnt _loopdevs = FlashKernel.flashKernelMounted mnt
    475 
    476 ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
    477 ubootFlashKernelFinalized p img mnt loopdevs = 
    478 	ubootFinalized p img mnt loopdevs
    479 		`before` flashKernelFinalized img mnt loopdevs
    480 
    481 -- | Normally a boot loader is installed on a disk image. However,
    482 -- when the disk image will be booted by eg qemu booting the kernel and
    483 -- initrd, no boot loader is needed, and this property can be used.
    484 noBootloader :: Property (HasInfo + UnixLike)
    485 noBootloader = pureInfoProperty "no bootloader" [NoBootloader]
    486 
    487 noBootloaderFinalized :: Finalization
    488 noBootloaderFinalized _img _mnt _loopDevs = doNothing
    489 
    490 imageChrootNotPresent :: DiskImage d => d -> Property UnixLike
    491 imageChrootNotPresent img = check (doesDirectoryExist dir) $
    492 	property "destroy the chroot used to build the image" $ makeChange $ do
    493 		removeChroot dir
    494 		nukeFile $ imageParttableFile img
    495   where
    496 	dir = imageChroot img
    497 
    498 imageChroot :: DiskImage d => d -> FilePath
    499 imageChroot img = imgfile <.> "chroot"
    500   where
    501 	RawDiskImage imgfile = rawDiskImage img
    502 
    503 imageParttableFile :: DiskImage d => d -> FilePath
    504 imageParttableFile img = imgfile <.> "parttable"
    505   where
    506 	RawDiskImage imgfile = rawDiskImage img
    507 
    508 isChild :: FilePath -> Maybe MountPoint -> Bool
    509 isChild mntpt (Just d)
    510 	| d `equalFilePath` mntpt = False
    511 	| otherwise = mntpt `dirContains` d
    512 isChild _ Nothing = False
    513 
    514 -- | From a location in a chroot (eg, /tmp/chroot/usr) to
    515 -- the corresponding location inside (eg, /usr).
    516 toSysDir :: FilePath -> FilePath -> FilePath
    517 toSysDir chrootdir d = case makeRelative chrootdir d of
    518 		"." -> "/"
    519 		sysdir -> "/" ++ sysdir