summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/DiskImage.hs
diff options
context:
space:
mode:
authorJoey Hess2015-10-22 20:13:47 -0400
committerJoey Hess2015-10-22 20:13:47 -0400
commit9f09b6236d33d68850f8d99d1ea482c47b47ae84 (patch)
tree61a5d8d956e022d2977d139fbf1786d3825302a7 /src/Propellor/Property/DiskImage.hs
parent9c1630d3c17b495ce97dfff5bd4a94c98c5b46db (diff)
disk image finalization may work
Diffstat (limited to 'src/Propellor/Property/DiskImage.hs')
-rw-r--r--src/Propellor/Property/DiskImage.hs101
1 files changed, 78 insertions, 23 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 8b74f478..4715ba08 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,8 +2,6 @@
--
-- This module is designed to be imported unqualified.
--
--- TODO run final
---
-- TODO avoid starting services while populating chroot and running final
module Propellor.Property.DiskImage (
@@ -49,7 +47,8 @@ import Propellor.Property.Partition
import Propellor.Property.Rsync
import Utility.Path
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, sortBy)
+import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
@@ -88,7 +87,7 @@ imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageBuilt' rebuild img mkchroot tabletype partspec final =
- imageBuiltFrom img chrootdir tabletype partspec (snd final)
+ imageBuiltFrom img chrootdir tabletype partspec final
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> doNothing)
`describe` desc
@@ -107,9 +106,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec final =
& Apt.cacheCleaned
-- | Builds a disk image from the contents of a chroot.
---
--- The passed property is run inside the mounted disk image.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
@@ -121,13 +118,18 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
<$> liftIO (dirSizes chrootdir)
let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
-- tie the knot!
- let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
+ let (mnts, t) = fitChrootSize tabletype partspec $
+ map (calcsz mnts) mnts
ensureProperty $
imageExists img (partTableSize t)
`before`
partitioned YesReallyDeleteDiskContents img t
`before`
- kpartx img (partitionsPopulated chrootdir mnts)
+ kpartx img (mkimg' mnts)
+ mkimg' mnts devs =
+ partitionsPopulated chrootdir mnts devs
+ `before`
+ imageFinalized final mnts devs
rmimg = File.notPresent img
partitionsPopulated :: FilePath -> [MountPoint] -> [LoopDev] -> Property NoInfo
@@ -139,7 +141,7 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m
go (Just mnt) loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir)
(const $ liftIO $ umountLazy tmpdir)
- $ \mounted -> if mounted
+ $ \ismounted -> if ismounted
then ensureProperty $
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
@@ -284,20 +286,73 @@ fitChrootSize tt l basesizes = (mounts, parttable)
-- | A pair of properties. The first property is satisfied within the
-- chroot, and is typically used to download the boot loader.
--- The second property is satisfied chrooted into the resulting
--- disk image, and will typically take care of installing the boot loader
--- to the disk image.
-type Finalization = (Property NoInfo, Property NoInfo)
+--
+-- 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.
+--
+-- It's ok if the second property leaves additional things mounted
+-- in the partition tree.
+type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+
+imageFinalized :: Finalization -> [MountPoint] -> [LoopDev] -> Property NoInfo
+imageFinalized (_, final) mnts devs = property "disk image finalized" $
+ withTmpDir "mnt" $ \top ->
+ go top `finally` liftIO (unmountall top)
+ where
+ go mnt = do
+ liftIO $ mountall mnt
+ ensureProperty $ final mnt devs
+
+ -- Ordered lexographically by mount point, so / comes before /usr
+ -- comes before /usr/local
+ orderedmntsdevs :: [(MountPoint, LoopDev)]
+ orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs
+
+ mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of
+ Nothing -> noop
+ Just p -> do
+ let mnt = top ++ p
+ createDirectoryIfMissing True mnt
+ unlessM (mount "auto" (partitionLoopDev loopdev) mnt) $
+ error $ "failed mounting " ++ mnt
+
+ unmountall top = do
+ unmountBelow top
+ umountLazy top
+
+noFinalization :: Finalization
+noFinalization = (doNothing, \_ _ -> doNothing)
-- | Makes grub be the boot loader of the disk image.
--- TODO not implemented
grubBooted :: Grub.BIOS -> Finalization
-grubBooted bios = (inchroot, inimg)
+grubBooted bios = (Grub.installed' bios, boots)
where
- -- Need to set up device.map manually before running update-grub.
- inchroot = Grub.installed' bios
-
- inimg = undefined
-
-noFinalization :: Finalization
-noFinalization = (doNothing, doNothing)
+ boots mnt loopdevs = combineProperties "disk image boots using grub"
+ -- bind mount host /dev so grub can access the loop devices
+ [ mounted "bind" "/dev" (mnt <> "dev")
+ , mounted "proc" "proc" (mnt <> "proc")
+ , mounted "sysfs" "sys" (mnt <> "sys")
+ -- work around for http://bugs.debian.org/802717
+ , check haveosprober $ inchroot "chmod" ["-x", osprober]
+ , inchroot "update-grub" []
+ , check haveosprober $ inchroot "chmod" ["+x", osprober]
+ , inchroot "grub-install" [wholediskloopdev]
+ -- 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" []
+ ]
+ where
+ inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
+
+ haveosprober = doesFileExist (mnt ++ 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!"