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.hs244
1 files changed, 193 insertions, 51 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 5bdd8f1a..5a41edd0 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,25 +1,54 @@
-{-# LANGUAGE FlexibleContexts #-}
+-- | Disk image generation.
+--
+-- This module is designed to be imported unqualified.
module Propellor.Property.DiskImage (
- built,
- rebuilt,
+ -- * Properties
+ DiskImage,
+ imageBuilt,
+ imageRebuilt,
+ imageBuiltFrom,
+ imageExists,
+ -- * Partitioning
+ Partition,
+ PartSize(..),
+ Fs(..),
+ PartSpec,
MountPoint,
- MkPartTable,
- fitChrootSize,
- freeSpace,
- DiskImageFinalization,
+ swapPartition,
+ partition,
+ mountedAt,
+ addFreeSpace,
+ setSize,
+ PartFlag(..),
+ setFlag,
+ TableType(..),
+ extended,
+ adjustp,
+ -- * Finalization
+ Finalization,
grubBooted,
Grub.BIOS(..),
+ noFinalization,
) where
import Propellor
-import Propellor.Property.Chroot
-import Propellor.Property.Parted
+import Propellor.Property.Chroot (Chroot)
+import Propellor.Property.Chroot.Util (removeChroot)
+import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Grub as Grub
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Apt as Apt
+import Propellor.Property.Parted
+import Propellor.Property.Mount
+import Utility.Path
import qualified Data.Map.Strict as M
+import qualified Data.ByteString.Lazy as L
import System.Posix.Files
+type DiskImage = FilePath
+
-- | Creates a bootable disk image.
--
-- First the specified Chroot is set up, and its properties are satisfied.
@@ -27,43 +56,100 @@ import System.Posix.Files
-- Then, the disk image is set up, and the chroot is copied into the
-- appropriate partition(s) of it.
--
--- Finally, the DiskImageFinalization property is
--- satisfied to make the disk image bootable.
---
+-- Example use:
+--
+-- > import Propellor.Property.DiskImage
+--
-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
--- > & Apt.installed ["openssh-server"]
+-- > & Apt.installed ["linux-image-amd64"]
-- > & ...
--- > partitions = fitChrootSize MSDOS
--- > [ (Just "/boot", mkPartiton EXT2)
--- > , (Just "/", mkPartition EXT4)
--- > , (Nothing, const (mkPartition LinuxSwap (MegaBytes 256)))
--- > ]
--- > in built chroot partitions (grubBooted PC)
-built :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-built = built' False
+-- > in imageBuilt "/srv/images/foo.img" chroot MSDOS
+-- > [ 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
+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.
-rebuilt :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-rebuilt = built' True
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+imageRebuilt = imageBuilt' True
-built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-built' rebuild mkparttable mkchroot final = undefined
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+imageBuilt' rebuild img mkchroot tabletype partspec final =
+ imageBuiltFrom img chrootdir tabletype partspec (snd final)
+ `requires` Chroot.provisioned chroot
+ `requires` (cleanrebuild <!> doNothing)
+ `describe` desc
+ where
+ desc = "built disk image " ++ img
+ cleanrebuild
+ | rebuild = property desc $ do
+ liftIO $ removeChroot chrootdir
+ return MadeChange
+ | otherwise = doNothing
+ chrootdir = img ++ ".chroot"
+ chroot = mkchroot chrootdir
+ -- First stage finalization.
+ & fst final
+ -- Avoid wasting disk image space on the apt cache
+ & Apt.cacheCleaned
--- TODO tie the knot
--- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)]
--- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts)
+-- | 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
+ -- 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
+ -- tie the knot!
+ let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
+ ensureProperty $
+ imageExists img (partTableSize t)
+ `before`
+ partitioned YesReallyDeleteDiskContents img t
+ rmimg = File.notPresent img
+
+-- | 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.
+--
+-- If the file is too large, truncates it down to the specified size.
+imageExists :: FilePath -> ByteSize -> Property NoInfo
+imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
+ ms <- catchMaybeIO $ getFileStatus img
+ case ms of
+ Just s
+ | toInteger (fileSize s) == toInteger sz -> return NoChange
+ | toInteger (fileSize s) > toInteger sz -> do
+ setFileSize img (fromInteger sz)
+ return MadeChange
+ _ -> do
+ L.writeFile img (L.replicate (fromIntegral sz) 0)
+ return MadeChange
-- | Generates a map of the sizes of the contents of
--- every directory in a filesystem tree.
+-- every directory in a filesystem tree.
+--
+-- (Hard links are counted multiple times for simplicity)
--
--- Should be same values as du -b
+-- Should be same values as du -bl
dirSizes :: FilePath -> IO (M.Map FilePath Integer)
dirSizes top = go M.empty top [top]
where
go m _ [] = return m
- go m dir (i:is) = do
+ go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do
s <- getSymbolicLinkStatus i
let sz = fromIntegral (fileSize s)
if isDirectory s
@@ -75,44 +161,100 @@ 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
+
+-- | From a location in a chroot (eg, /tmp/chroot/usr) to
+-- the corresponding location inside (eg, /usr).
+toSysDir :: FilePath -> FilePath -> FilePath
+toSysDir chrootdir d = case makeRelative chrootdir d of
+ "." -> "/"
+ sysdir -> "/" ++ sysdir
+
-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.
type MountPoint = Maybe FilePath
--- | This is provided with a list of the sizes of directories in the chroot
--- under each mount point. The input list corresponds to the list of mount
--- points that the function returns! This trick is accomplished by
--- exploiting laziness and tying the knot.
+defSz :: PartSize
+defSz = MegaBytes 128
+
+-- | 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.
--
--- (Partitions that are not mounted (ie, LinuxSwap) will have 128 MegaBytes
+-- (Partitions that are not to be mounted (ie, LinuxSwap), or that have
+-- no corresponding directory in the chroot will have 128 MegaBytes
-- provided as a default size.)
-type MkPartTable = [PartSize] -> ([MountPoint], PartTable)
+type PartSpec = (MountPoint, PartSize -> Partition)
+
+-- | Specifies a swap partition of a given size.
+swapPartition :: PartSize -> PartSpec
+swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz))
+
+-- | Specifies a partition with a given filesystem.
+--
+-- The partition is not mounted anywhere by default; use the combinators
+-- below to configure it.
+partition :: Fs -> PartSpec
+partition fs = (Nothing, mkPartition fs)
+
+-- | Specifies where to mount a partition.
+mountedAt :: PartSpec -> FilePath -> PartSpec
+mountedAt (_, p) mp = (Just mp, p)
+
+-- | Adds additional free space to the partition.
+addFreeSpace :: PartSpec -> PartSize -> PartSpec
+addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz))
+
+-- | Forced a partition to be a specific size, instead of scaling to the
+-- size needed for the files in the chroot.
+setSize :: PartSpec -> PartSize -> PartSpec
+setSize (mp, p) sz = (mp, const (p sz))
+
+-- | Sets a flag on the partition.
+setFlag :: PartSpec -> PartFlag -> PartSpec
+setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
+
+-- | Makes a MSDOS partition be Extended, rather than Primary.
+extended :: PartSpec -> PartSpec
+extended s = adjustp s $ \p -> p { partType = Extended }
+
+adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec
+adjustp (mp, p) f = (mp, \sz -> f (p sz))
-- | The constructor for each Partition is passed the size of the files
-- from the chroot that will be put in that partition.
---
--- Partitions that are not mounted (ie, LinuxSwap) will have their size
--- set to 128 MegaBytes, unless it's overridden.
-fitChrootSize :: TableType -> [(MountPoint, PartSize -> Partition)] -> MkPartTable
+fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTable)
fitChrootSize tt l basesizes = (mounts, parttable)
where
(mounts, sizers) = unzip l
parttable = PartTable tt (map (uncurry id) (zip sizers basesizes))
--- | After populating the partitions with files from the chroot,
--- they will have remaining free space equal to the sizes of the input
--- partitions.
-freeSpace :: TableType -> [(MountPoint, Partition)] -> MkPartTable
-freeSpace tt = fitChrootSize tt . map (\(mnt, p) -> (mnt, adjustsz p))
- where
- adjustsz p basesize = p { partSize = partSize p <> basesize }
-
-- | 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 DiskImageFinalization = (Property NoInfo, Property NoInfo)
+type Finalization = (Property NoInfo, Property NoInfo)
-- | Makes grub be the boot loader of the disk image.
-grubBooted :: Grub.BIOS -> DiskImageFinalization
+grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed bios, undefined)
+
+noFinalization :: Finalization
+noFinalization = (doNothing, doNothing)