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.hs81
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