diff options
Diffstat (limited to 'src/Propellor/Property/DiskImage.hs')
| -rw-r--r-- | src/Propellor/Property/DiskImage.hs | 81 |
1 files changed, 49 insertions, 32 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 48df7fab..8c027b05 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -2,6 +2,8 @@ -- -- This module is designed to be imported unqualified. +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.DiskImage ( -- * Partition specification module Propellor.Property.DiskImage.PartSpec, @@ -30,6 +32,7 @@ import Propellor.Property.Parted import Propellor.Property.Mount import Propellor.Property.Partition import Propellor.Property.Rsync +import Propellor.Container import Utility.Path import Data.List (isPrefixOf, isInfixOf, sortBy) @@ -51,7 +54,8 @@ type DiskImage = FilePath -- -- > import Propellor.Property.DiskImage -- --- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d +-- > let chroot d = Chroot.debootstrapped mempty d +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["linux-image-amd64"] -- > & User.hasPassword (User "root") -- > & User.accountFor (User "demo") @@ -89,31 +93,44 @@ imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finaliz imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot - `requires` (cleanrebuild <!> doNothing) + `requires` (cleanrebuild <!> (doNothing :: Property UnixLike)) `describe` desc where desc = "built disk image " ++ img + cleanrebuild :: Property Linux cleanrebuild | rebuild = property desc $ do liftIO $ removeChroot chrootdir return MadeChange | otherwise = doNothing chrootdir = img ++ ".chroot" - chroot = mkchroot chrootdir - -- Before ensuring any other properties of the chroot, avoid - -- starting services. Reverted by imageFinalized. - &^ Chroot.noServices - -- First stage finalization. - & fst final - -- Avoid wasting disk image space on the apt cache - & Apt.cacheCleaned + chroot = + let c = 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 + +-- | This property is automatically added to the chroot when building a +-- disk image. It cleans any caches of information that can be omitted; +-- eg the apt cache on Debian. +cachesCleaned :: Property UnixLike +cachesCleaned = withOS "cache cleaned" $ \w o -> + let aptclean = ensureProperty w Apt.cacheCleaned + in case o of + (Just (System (Debian _) _)) -> aptclean + (Just (System (Buntish _) _)) -> aptclean + _ -> noChange -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg where desc = img ++ " built from " ++ chrootdir - mkimg = property desc $ do + mkimg = property' desc $ \w -> do -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir @@ -123,7 +140,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg -- tie the knot! let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts - ensureProperty $ + ensureProperty w $ imageExists img (partTableSize parttable) `before` partitioned YesReallyDeleteDiskContents img parttable @@ -136,16 +153,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg rmimg = File.notPresent img partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux -partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs +partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> + mconcat $ zipWith3 (go w) mnts mntopts devs where desc = "partitions populated from " ++ chrootdir - go Nothing _ _ = noChange - go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + go _ Nothing _ _ = noChange + go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) (const $ liftIO $ umountLazy tmpdir) $ \ismounted -> if ismounted - then ensureProperty $ + then ensureProperty w $ syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir else return FailedChange @@ -230,15 +248,15 @@ type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = - property "disk image finalized" $ + property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> - go top `finally` liftIO (unmountall top) + go w top `finally` liftIO (unmountall top) where - go top = do + go w top = do liftIO $ mountall top liftIO $ writefstab top liftIO $ allowservices top - ensureProperty $ final top devs + ensureProperty w $ final top devs -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local @@ -280,27 +298,26 @@ noFinalization = (doNothing, \_ _ -> doNothing) grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed' bios, boots) where - boots mnt loopdevs = combineProperties "disk image boots using grub" + 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 + & 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"] + & inchroot "update-initramfs" ["-u"] `assume` MadeChange -- work around for http://bugs.debian.org/802717 - , check haveosprober $ inchroot "chmod" ["-x", osprober] - , inchroot "update-grub" [] + & check haveosprober (inchroot "chmod" ["-x", osprober]) + & inchroot "update-grub" [] `assume` MadeChange - , check haveosprober $ inchroot "chmod" ["+x", osprober] - , inchroot "grub-install" [wholediskloopdev] + & 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" [] + & cmdProperty "sync" [] `assume` NoChange - ] where -- cannot use </> since the filepath is absolute inmnt f = mnt ++ f |