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.hs75
1 files changed, 57 insertions, 18 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 5a41edd0..7a3460cb 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,6 +1,10 @@
-- | Disk image generation.
--
-- 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 (
-- * Properties
@@ -41,8 +45,11 @@ 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.Partition
+import Propellor.Property.Rsync
import Utility.Path
+import Data.List (isPrefixOf)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
@@ -64,8 +71,10 @@ type DiskImage = FilePath
-- > & Apt.installed ["linux-image-amd64"]
-- > & ...
-- > in imageBuilt "/srv/images/foo.img" chroot MSDOS
--- > [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag
--- > , partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100
+-- > [ partition EXT2 `mountedAt` "/boot"
+-- > `setFlag` BootFlag
+-- > , partition EXT4 `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 100
-- > , swapPartition (MegaBytes 256)
-- > ] (grubBooted PC)
imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
@@ -100,27 +109,52 @@ imageBuilt' rebuild img mkchroot tabletype partspec final =
-- | Builds a disk image from the contents of a chroot.
--
-- The passed property is run inside the mounted disk image.
---
--- TODO copy in
--- TODO run final
imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
where
- mkimg = property (img ++ " built from " ++ chrootdir) $ do
+ desc = img ++ " built from " ++ chrootdir
+ mkimg = property desc $ do
-- unmount helper filesystems such as proc from the chroot
-- before getting sizes
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
- let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts
+ let calcsz = \mnts -> maybe defSz fudge . getMountSz szm mnts
-- tie the knot!
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)
rmimg = File.notPresent img
+partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo
+partitionsPopulated chrootdir mnts devs = property desc $
+ mconcat $ map (uncurry go) (zip mnts devs)
+ where
+ desc = "partitions populated from " ++ chrootdir
+
+ go Nothing _ = noChange
+ go (Just mnt) dev = withTmpDir "mnt" $ \tmpdir -> bracket
+ (liftIO $ mount "auto" dev tmpdir)
+ (const $ liftIO $ umountLazy tmpdir)
+ $ \mounted -> if mounted
+ then ensureProperty $
+ syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
+ else return FailedChange
+
+ filtersfor mnt =
+ let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
+ filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m)
+ (catMaybes mnts)
+ in concatMap (\m ->
+ -- Include the child mount point, but exclude its contents.
+ [ Include (Pattern m)
+ , Exclude (filesUnder m)
+ ]) childmnts
+
-- | Ensures that a disk image file of the specified size exists.
--
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
@@ -161,22 +195,19 @@ dirSizes top = go M.empty top [top]
else go (M.insertWith (+) dir sz m) dir is
subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
--- | Gets the size to allocate for a particular mount point, given the
--- map of sizes.
---
--- A list of all mount points is provided, so that when eg calculating
--- the size for /, if /boot is a mount point, its size can be subtracted.
getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize
getMountSz _ _ Nothing = Nothing
getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
childsz = mconcat $ catMaybes $
- map (getMountSz szm l) (filter childmntpt l)
- childmntpt Nothing = False
- childmntpt (Just d)
- | d `equalFilePath` mntpt = False
- | otherwise = mntpt `dirContains` d
+ map (getMountSz szm l) (filter (isChild mntpt) l)
+
+isChild :: FilePath -> MountPoint -> Bool
+isChild mntpt (Just d)
+ | d `equalFilePath` mntpt = False
+ | otherwise = mntpt `dirContains` d
+isChild _ Nothing = False
-- | From a location in a chroot (eg, /tmp/chroot/usr) to
-- the corresponding location inside (eg, /usr).
@@ -191,11 +222,19 @@ type MountPoint = Maybe FilePath
defSz :: PartSize
defSz = MegaBytes 128
+-- Add 2% for filesystem overhead. Rationalle for picking 2%:
+-- A filesystem with 1% overhead might just sneak by as acceptable.
+-- Double that just in case. Add an additional 3 mb to deal with
+-- non-scaling overhead, of filesystems (eg, superblocks).
+fudge :: PartSize -> PartSize
+fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3)
+
-- | Specifies a mount point and a constructor for a Partition.
--
-- The size that is eventually provided is the amount of space needed to
-- hold the files that appear in the directory where the partition is to be
--- mounted.
+-- mounted. Plus a fudge factor, since filesystems have some space
+-- overhead.
--
-- (Partitions that are not to be mounted (ie, LinuxSwap), or that have
-- no corresponding directory in the chroot will have 128 MegaBytes