summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2017-08-24 11:37:22 -0400
committerJoey Hess2017-08-24 11:37:22 -0400
commit1486b8d5bceba8f28bc06f5e6152209a624dd4fb (patch)
tree9095a5f9660580f0440c4c7dbf778e7e25780b97
parent3e96b093874f2d8d35ea2337d658fa308e8c41a4 (diff)
DiskImage type class
* DiskImage: Made a DiskImage type class, so that different disk image formats can be implemented. The properties in this module can generate any type that is a member of DiskImage. (API change) (To convert existing configs, convert the filename of the disk image to RawDiskImage filename.) * Removed DiskImage.vmdkBuiltFor property. (API change) Instead, use VirtualBoxPointer in the property that creates the disk image. This commit was sponsored by Jack Hill on Patreon.
-rw-r--r--debian/changelog13
-rw-r--r--doc/forum/DiskImage_creation_does_not_work_on_my_system/comment_10_7982113b64a7884ce95ff38a6d876e2e._comment7
-rw-r--r--joeyconfig.hs3
-rw-r--r--src/Propellor/Property/DiskImage.hs104
4 files changed, 88 insertions, 39 deletions
diff --git a/debian/changelog b/debian/changelog
index f8b59743..9b01183f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,16 @@
+propellor (4.8.0) UNRELEASED; urgency=medium
+
+ * DiskImage: Made a DiskImage type class, so that different disk image
+ formats can be implemented. The properties in this module can generate
+ any type that is a member of DiskImage. (API change)
+ (To convert existing configs, convert the filename of the disk image
+ to RawDiskImage filename.)
+ * Removed DiskImage.vmdkBuiltFor property. (API change)
+ Instead, use VirtualBoxPointer in the property that creates the disk
+ image.
+
+ -- Joey Hess <id@joeyh.name> Thu, 24 Aug 2017 11:00:19 -0400
+
propellor (4.7.7) unstable; urgency=medium
* Locale: Display an error message when /etc/locale.gen does not contain
diff --git a/doc/forum/DiskImage_creation_does_not_work_on_my_system/comment_10_7982113b64a7884ce95ff38a6d876e2e._comment b/doc/forum/DiskImage_creation_does_not_work_on_my_system/comment_10_7982113b64a7884ce95ff38a6d876e2e._comment
new file mode 100644
index 00000000..3ccfc4db
--- /dev/null
+++ b/doc/forum/DiskImage_creation_does_not_work_on_my_system/comment_10_7982113b64a7884ce95ff38a6d876e2e._comment
@@ -0,0 +1,7 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 10"""
+ date="2017-08-24T15:35:22Z"
+ content="""
+I've implemented the DiskImage type class.
+"""]]
diff --git a/joeyconfig.hs b/joeyconfig.hs
index 1ce15682..e98e5b51 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -94,12 +94,11 @@ darkstar = host "darkstar.kitenet.net" $ props
& Ssh.userKeys (User "joey") hostContext
[ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar")
]
- & imageBuilt "/srv/test.img" mychroot MSDOS
+ & imageBuilt (VirtualBoxPointer "/srv/test.vmdk") mychroot MSDOS
[ partition EXT2 `mountedAt` "/boot"
, partition EXT4 `mountedAt` "/"
, swapPartition (MegaBytes 256)
]
- `before` vmdkBuiltFor "/srv/test.img"
where
mychroot d = debootstrapped mempty d $ props
& osDebian Unstable X86_64
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index f64f685a..6c1a572c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -8,12 +8,13 @@ module Propellor.Property.DiskImage (
-- * Partition specification
module Propellor.Property.DiskImage.PartSpec,
-- * Properties
- DiskImage,
+ DiskImage(..),
+ RawDiskImage(..),
+ VirtualBoxPointer(..),
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
- vmdkBuiltFor,
Grub.BIOS(..),
) where
@@ -42,7 +43,48 @@ 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.
--
@@ -70,7 +112,7 @@ type DiskImage = FilePath
-- > import Propellor.Property.Chroot
-- >
-- > foo = host "foo.example.com" $ props
--- > & imageBuilt "/srv/diskimages/disk.img" mychroot
+-- > & imageBuilt (RawDiskImage "/srv/diskimages/disk.img") mychroot
-- > MSDOS
-- > [ partition EXT2 `mountedAt` "/boot"
-- > `setFlag` BootFlag
@@ -95,7 +137,7 @@ type DiskImage = FilePath
--
-- > foo :: Host
-- > foo = host "foo.example.com" $ props
--- > & imageBuilt "/srv/diskimages/bar-disk.img"
+-- > & imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img")
-- > (hostChroot bar (Debootstrapped mempty))
-- > MSDOS
-- > [ partition EXT2 `mountedAt` "/boot"
@@ -111,30 +153,31 @@ type DiskImage = FilePath
-- > & Apt.installed ["linux-image-amd64"]
-- > & Grub.installed PC
-- > & hasPassword (User "root")
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
+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 -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
+imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
+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 = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
@@ -161,10 +204,11 @@ 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 + DebianLike) 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
-- first; don't want to include the contents of those.
@@ -176,14 +220,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
ensureProperty w $
- imageExists' img parttable
+ imageExists' dest parttable
`before`
- kpartx img (mkimg' mnts mntopts parttable)
+ kpartx imgfile (mkimg' mnts mntopts parttable)
+ `before`
+ buildDiskImage img
mkimg' mnts mntopts parttable devs =
partitionsPopulated chrootdir mnts mntopts devs
`before`
imageFinalized final mnts mntopts devs parttable
- rmimg = undoRevertableProperty (imageExists' img dummyparttable)
+ rmimg = undoRevertableProperty (buildDiskImage img)
+ `before` undoRevertableProperty (imageExists' dest dummyparttable)
dummyparttable = PartTable tabletype []
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
@@ -255,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 isz = 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
@@ -278,14 +325,14 @@ imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do
--
-- Avoids repartitioning the disk image, when a file of the right size
-- already exists, and it has the same PartTable.
-imageExists' :: FilePath -> PartTable -> RevertableProperty DebianLike UnixLike
-imageExists' img parttable = (setup <!> cleanup) `describe` desc
+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 img (partTableSize parttable)
+ res <- ensureProperty w $ imageExists dest (partTableSize parttable)
if res == NoChange && oldparttable == show parttable
then return NoChange
else if res == FailedChange
@@ -385,20 +432,3 @@ toSysDir :: FilePath -> FilePath -> FilePath
toSysDir chrootdir d = case makeRelative chrootdir d of
"." -> "/"
sysdir -> "/" ++ sysdir
-
--- | Builds a VirtualBox .vmdk file for the specified disk image file.
-vmdkBuiltFor :: FilePath -> RevertableProperty DebianLike UnixLike
-vmdkBuiltFor diskimage = (setup <!> cleanup)
- `describe` (vmdkfile ++ " built")
- where
- vmdkfile = diskimage ++ ".vmdk"
- 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 = File.notPresent vmdkfile