summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/DiskImage.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/DiskImage.hs')
-rw-r--r--src/Propellor/Property/DiskImage.hs290
1 files changed, 189 insertions, 101 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 06dfa69c..6c1a572c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -8,71 +8,95 @@ module Propellor.Property.DiskImage (
-- * Partition specification
module Propellor.Property.DiskImage.PartSpec,
-- * Properties
- DiskImage,
+ DiskImage(..),
+ RawDiskImage(..),
+ VirtualBoxPointer(..),
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
- -- * Finalization
- Finalization,
- grubBooted,
Grub.BIOS(..),
- noFinalization,
) where
import Propellor.Base
import Propellor.Property.DiskImage.PartSpec
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
+import Propellor.Property.Mount
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Parted
-import Propellor.Property.Mount
import Propellor.Property.Fstab (SwapPartition(..), genFstab)
import Propellor.Property.Partition
import Propellor.Property.Rsync
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
import Propellor.Container
import Utility.Path
+import Utility.FileMode
-import Data.List (isPrefixOf, isInfixOf, sortBy)
+import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4)
import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
-type DiskImage = FilePath
+-- | Type class of disk image formats.
+class DiskImage d where
+ -- | Get the location where the raw disk image should be stored.
+ rawDiskImage :: d -> RawDiskImage
+ -- | Describe the disk image (for display to the user)
+ describeDiskImage :: d -> String
+ -- | Convert the raw disk image file in the
+ -- `rawDiskImage` location into the desired disk image format.
+ -- For best efficiency, the raw disk imasge file should be left
+ -- unchanged on disk.
+ buildDiskImage :: d -> RevertableProperty DebianLike Linux
+
+-- | A raw disk image, that can be written directly out to a disk.
+newtype RawDiskImage = RawDiskImage FilePath
+
+instance DiskImage RawDiskImage where
+ rawDiskImage = id
+ describeDiskImage (RawDiskImage f) = f
+ buildDiskImage (RawDiskImage _) = doNothing <!> doNothing
+
+-- | A virtualbox .vmdk file, which contains a pointer to the raw disk
+-- image. This can be built very quickly.
+newtype VirtualBoxPointer = VirtualBoxPointer FilePath
+
+instance DiskImage VirtualBoxPointer where
+ rawDiskImage (VirtualBoxPointer f) = RawDiskImage $
+ dropExtension f ++ ".img"
+ describeDiskImage (VirtualBoxPointer f) = f
+ buildDiskImage (VirtualBoxPointer vmdkfile) = (setup <!> cleanup)
+ `describe` (vmdkfile ++ " built")
+ where
+ setup = cmdProperty "VBoxManage"
+ [ "internalcommands", "createrawvmdk"
+ , "-filename", vmdkfile
+ , "-rawdisk", diskimage
+ ]
+ `changesFile` vmdkfile
+ `onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes))
+ `requires` Apt.installed ["virtualbox"]
+ `requires` File.notPresent vmdkfile
+ cleanup = tightenTargets $ File.notPresent vmdkfile
+ RawDiskImage diskimage = rawDiskImage (VirtualBoxPointer vmdkfile)
-- | Creates a bootable disk image.
--
-- First the specified Chroot is set up, and its properties are satisfied.
--
-- Then, the disk image is set up, and the chroot is copied into the
--- appropriate partition(s) of it.
---
--- Example use:
---
--- > import Propellor.Property.DiskImage
---
--- > let chroot d = Chroot.debootstrapped mempty d
--- > & osDebian Unstable X86_64
--- > & Apt.installed ["linux-image-amd64"]
--- > & User.hasPassword (User "root")
--- > & User.accountFor (User "demo")
--- > & User.hasPassword (User "demo")
--- > & User.hasDesktopGroups (User "demo")
--- > & ...
--- > in imageBuilt "/srv/images/foo.img" chroot
--- > MSDOS (grubBooted PC)
--- > [ partition EXT2 `mountedAt` "/boot"
--- > `setFlag` BootFlag
--- > , partition EXT4 `mountedAt` "/"
--- > `addFreeSpace` MegaBytes 100
--- > `mountOpt` errorReadonly
--- > , swapPartition (MegaBytes 256)
--- > ]
+-- appropriate partition(s) of it.
--
+-- The partitions default to being sized just large enough to fit the files
+-- from the chroot. You can use `addFreeSpace` to make them a bit larger
+-- than that, or `setSize` to use a fixed size.
+--
-- Note that the disk image file is reused if it already exists,
-- to avoid expensive IO to generate a new one. And, it's updated in-place,
-- so its contents are undefined during the build process.
@@ -81,39 +105,95 @@ type DiskImage = FilePath
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
+--
+-- Example use:
+--
+-- > import Propellor.Property.DiskImage
+-- > import Propellor.Property.Chroot
+-- >
+-- > foo = host "foo.example.com" $ props
+-- > & imageBuilt (RawDiskImage "/srv/diskimages/disk.img") mychroot
+-- > MSDOS
+-- > [ partition EXT2 `mountedAt` "/boot"
+-- > `setFlag` BootFlag
+-- > , partition EXT4 `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 100
+-- > `mountOpt` errorReadonly
+-- > , swapPartition (MegaBytes 256)
+-- > ]
+-- > where
+-- > mychroot d = debootstrapped mempty d $ props
+-- > & osDebian Unstable X86_64
+-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
+-- > & User.hasPassword (User "root")
+-- > & User.accountFor (User "demo")
+-- > & User.hasPassword (User "demo")
+-- > & User.hasDesktopGroups (User "demo")
+-- > & ...
+--
+-- This can also be used with `Chroot.hostChroot` to build a disk image
+-- that has all the properties of a Host. For example:
+--
+-- > foo :: Host
+-- > foo = host "foo.example.com" $ props
+-- > & imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img")
+-- > (hostChroot bar (Debootstrapped mempty))
+-- > MSDOS
+-- > [ partition EXT2 `mountedAt` "/boot"
+-- > `setFlag` BootFlag
+-- > , partition EXT4 `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 5000
+-- > , swapPartition (MegaBytes 256)
+-- > ]
+-- >
+-- > bar :: Host
+-- > bar = host "bar.example.com" $ props
+-- > & osDebian Unstable X86_64
+-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
+-- > & hasPassword (User "root")
+imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
+imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
-imageBuilt' rebuild img mkchroot tabletype final partspec =
+imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
+imageBuilt' rebuild img mkchroot tabletype partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
`describe` desc
where
- desc = "built disk image " ++ img
+ desc = "built disk image " ++ describeDiskImage img
+ RawDiskImage imgfile = rawDiskImage img
cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
- chrootdir = img ++ ".chroot"
+ chrootdir = imgfile ++ ".chroot"
chroot =
- let c = mkchroot chrootdir
+ let c = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
-- Before ensuring any other properties of the chroot,
-- avoid starting services. Reverted by imageFinalized.
&^ Chroot.noServices
- -- First stage finalization.
- & fst final
& cachesCleaned
+ -- Only propagate privdata Info from this chroot, nothing else.
+ propprivdataonly (Chroot.Chroot d b ip h) =
+ Chroot.Chroot d b (\c _ -> ip c onlyPrivData) h
+ -- Pick boot loader finalization based on which bootloader is
+ -- installed.
+ final = case fromInfo (containerInfo chroot) of
+ [GrubInstalled] -> grubBooted
+ [] -> unbootable "no bootloader is installed"
+ _ -> unbootable "multiple bootloaders are installed; don't know which to use"
-- | This property is automatically added to the chroot when building a
-- disk image. It cleans any caches of information that can be omitted;
@@ -124,13 +204,14 @@ cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
skipit = doNothing :: Property UnixLike
-- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
+imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
- desc = img ++ " built from " ++ chrootdir
+ desc = describeDiskImage img ++ " built from " ++ chrootdir
+ dest@(RawDiskImage imgfile) = rawDiskImage img
mkimg = property' desc $ \w -> do
- -- unmount helper filesystems such as proc from the chroot
- -- before getting sizes
+ -- Unmount helper filesystems such as proc from the chroot
+ -- first; don't want to include the contents of those.
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
@@ -139,18 +220,20 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
ensureProperty w $
- imageExists img (partTableSize parttable)
+ imageExists' dest parttable
`before`
- partitioned YesReallyDeleteDiskContents img parttable
+ kpartx imgfile (mkimg' mnts mntopts parttable)
`before`
- kpartx img (mkimg' mnts mntopts parttable)
+ buildDiskImage img
mkimg' mnts mntopts parttable devs =
partitionsPopulated chrootdir mnts mntopts devs
`before`
imageFinalized final mnts mntopts devs parttable
- rmimg = File.notPresent img
+ rmimg = undoRevertableProperty (buildDiskImage img)
+ `before` undoRevertableProperty (imageExists' dest dummyparttable)
+ dummyparttable = PartTable tabletype []
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
mconcat $ zipWith3 (go w) mnts mntopts devs
where
@@ -179,10 +262,10 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
-- The constructor for each Partition is passed the size of the files
-- from the chroot that will be put in that partition.
-fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
+fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
where
- (mounts, mountopts, sizers) = unzip3 l
+ (mounts, mountopts, sizers, _) = unzip4 l
parttable = PartTable tt (zipWith id sizers basesizes)
-- | Generates a map of the sizes of the contents of
@@ -219,8 +302,8 @@ getMountSz szm l (Just mntpt) =
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- If the file is too large, truncates it down to the specified size.
-imageExists :: FilePath -> ByteSize -> Property Linux
-imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
+imageExists :: RawDiskImage -> ByteSize -> Property Linux
+imageExists (RawDiskImage img) isz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
Just s
@@ -231,21 +314,47 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
_ -> do
L.writeFile img (L.replicate (fromIntegral sz) 0)
return MadeChange
+ where
+ sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize
+ -- Disks have a sector size, and making a disk image not
+ -- aligned to a sector size will confuse some programs.
+ -- Common sector sizes are 512 and 4096; use 4096 as it's larger.
+ sectorsize = 4096 :: Double
--- | A pair of properties. The first property is satisfied within the
--- chroot, and is typically used to download the boot loader.
+-- | Ensure that disk image file exists and is partitioned.
--
--- The second property is run after the disk image is created,
--- with its populated partition tree mounted in the provided
--- location from the provided loop devices. This will typically
--- take care of installing the boot loader to the image.
+-- Avoids repartitioning the disk image, when a file of the right size
+-- already exists, and it has the same PartTable.
+imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
+imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc
+ where
+ desc = "disk image exists " ++ img
+ parttablefile = img ++ ".parttable"
+ setup = property' desc $ \w -> do
+ oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
+ res <- ensureProperty w $ imageExists dest (partTableSize parttable)
+ if res == NoChange && oldparttable == show parttable
+ then return NoChange
+ else if res == FailedChange
+ then return FailedChange
+ else do
+ liftIO $ writeFile parttablefile (show parttable)
+ ensureProperty w $ partitioned YesReallyDeleteDiskContents img parttable
+ cleanup = File.notPresent img
+ `before`
+ File.notPresent parttablefile
+
+-- | A property that is run after the disk image is created, with
+-- its populated partition tree mounted in the provided
+-- location from the provided loop devices. This is typically used to
+-- install a boot loader in the image's superblock.
--
--- It's ok if the second property leaves additional things mounted
+-- It's ok if the property leaves additional things mounted
-- in the partition tree.
-type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
+type Finalization = (FilePath -> [LoopDev] -> Property Linux)
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
+imageFinalized final mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
@@ -289,48 +398,27 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
-noFinalization :: Finalization
-noFinalization = (doNothing, \_ _ -> doNothing)
+unbootable :: String -> Finalization
+unbootable msg = \_ _ -> property desc $ do
+ warningMessage (desc ++ ": " ++ msg)
+ return FailedChange
+ where
+ desc = "image is not bootable"
-- | Makes grub be the boot loader of the disk image.
-grubBooted :: Grub.BIOS -> Finalization
-grubBooted bios = (Grub.installed' bios, boots)
+--
+-- This does not install the grub package. You will need to add
+-- the `Grub.installed` property to the chroot.
+grubBooted :: Finalization
+grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
+ `describe` "disk image boots using grub"
where
- boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
- -- bind mount host /dev so grub can access the loop devices
- & bindMount "/dev" (inmnt "/dev")
- & mounted "proc" "proc" (inmnt "/proc") mempty
- & mounted "sysfs" "sys" (inmnt "/sys") mempty
- -- update the initramfs so it gets the uuid of the root partition
- & inchroot "update-initramfs" ["-u"]
- `assume` MadeChange
- -- work around for http://bugs.debian.org/802717
- & check haveosprober (inchroot "chmod" ["-x", osprober])
- & inchroot "update-grub" []
- `assume` MadeChange
- & check haveosprober (inchroot "chmod" ["+x", osprober])
- & inchroot "grub-install" [wholediskloopdev]
- `assume` MadeChange
- -- sync all buffered changes out to the disk image
- -- may not be necessary, but seemed needed sometimes
- -- when using the disk image right away.
- & cmdProperty "sync" []
- `assume` NoChange
- where
- -- cannot use </> since the filepath is absolute
- inmnt f = mnt ++ f
-
- inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
-
- haveosprober = doesFileExist (inmnt osprober)
- osprober = "/etc/grub.d/30_os-prober"
-
- -- It doesn't matter which loopdev we use; all
- -- come from the same disk image, and it's the loop dev
- -- for the whole disk image we seek.
- wholediskloopdev = case loopdevs of
- (l:_) -> wholeDiskLoopDev l
- [] -> error "No loop devs provided!"
+ -- It doesn't matter which loopdev we use; all
+ -- come from the same disk image, and it's the loop dev
+ -- for the whole disk image we seek.
+ wholediskloopdev = case loopdevs of
+ (l:_) -> wholeDiskLoopDev l
+ [] -> error "No loop devs provided!"
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)