summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-09-01 11:09:50 -0700
committerJoey Hess2015-09-01 11:09:50 -0700
commite85a15d160005929a9d5ea5cb21c25751856c5ae (patch)
tree8ec3ce2792d50674a0f2e7f8a6de3c5fc2911cec
parent60950b159a2b800938929f8ae12823d5ec674667 (diff)
keystone for disk image creation
Untested, and grub booting not done.
-rw-r--r--src/Propellor/Property/DiskImage.hs65
-rw-r--r--src/Propellor/Property/Parted.hs11
2 files changed, 63 insertions, 13 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 5bdd8f1a..f649b7bb 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -3,6 +3,7 @@
module Propellor.Property.DiskImage (
built,
rebuilt,
+ exists,
MountPoint,
MkPartTable,
fitChrootSize,
@@ -13,14 +14,17 @@ module Propellor.Property.DiskImage (
) where
import Propellor
-import Propellor.Property.Chroot
+import Propellor.Property.Chroot (Chroot)
+import qualified Propellor.Property.Chroot as Chroot
import Propellor.Property.Parted
import qualified Propellor.Property.Grub as Grub
+import qualified Propellor.Property.File as File
import qualified Data.Map.Strict as M
+import qualified Data.ByteString.Lazy as L
import System.Posix.Files
--- | Creates a bootable disk image.
+-- | Creates a bootable disk image in the specified file.
--
-- First the specified Chroot is set up, and its properties are satisfied.
--
@@ -39,21 +43,51 @@ import System.Posix.Files
-- > , (Nothing, const (mkPartition LinuxSwap (MegaBytes 256)))
-- > ]
-- > in built chroot partitions (grubBooted PC)
-built :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
+built :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
built = built' 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 :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
rebuilt = built' True
-built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-built' rebuild mkparttable mkchroot final = undefined
+built' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
+built' rebuild img mkchroot mkparttable final =
+ (mkimg <!> unmkimg)
+ `requires` Chroot.provisioned (mkchroot chrootdir)
+ `describe` desc
+ where
+ desc = "built disk image " ++ img
+ unmkimg = File.notPresent img
+ chrootdir = img ++ ".chroot"
+ mkimg = property desc $ do
+ szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir
+ -- tie the knot!
+ let (mnts, t) = mkparttable (map (getMountSz szm) mnts)
+ let disksz = partTableSize t
+ ensureProperty $
+ exists img disksz
+ `before`
+ partitioned YesReallyDeleteDiskContents img t
--- TODO tie the knot
--- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)]
--- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts)
+-- | 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.
+exists :: FilePath -> ByteSize -> Property NoInfo
+exists 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.
@@ -78,20 +112,25 @@ dirSizes top = go M.empty top [top]
-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.
type MountPoint = Maybe FilePath
+getMountSz :: (M.Map FilePath PartSize) -> MountPoint -> PartSize
+getMountSz _ Nothing = defSz
+getMountSz szm (Just mntpt) = M.findWithDefault defSz mntpt szm
+
+defSz :: PartSize
+defSz = MegaBytes 128
+
-- | 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.
--
--- (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)
-- | 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 tt l basesizes = (mounts, parttable)
where
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 29d94b4c..4e2efe24 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -3,12 +3,14 @@
module Propellor.Property.Parted (
TableType(..),
PartTable(..),
+ partTableSize,
Partition(..),
mkPartition,
Partition.Fs(..),
PartSize(..),
ByteSize,
toPartSize,
+ fromPartSize,
Partition.MkfsOpts,
PartType(..),
PartFlag(..),
@@ -45,6 +47,12 @@ instance Monoid PartTable where
-- | uses the TableType of the second parameter
mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2)
+-- | Gets the total size of the disk specified by the partition table.
+partTableSize :: PartTable -> ByteSize
+partTableSize (PartTable _ ps) = fromPartSize $
+ -- add 1 megabyte to hold the partition table itself
+ mconcat (MegaBytes 1 : map partSize ps)
+
-- | A partition on the disk.
data Partition = Partition
{ partType :: PartType
@@ -89,6 +97,9 @@ instance PartedVal PartSize where
toPartSize :: ByteSize -> PartSize
toPartSize b = MegaBytes (b `div` 1000000)
+fromPartSize :: PartSize -> ByteSize
+fromPartSize (MegaBytes b) = b * 1000000
+
instance Monoid PartSize where
mempty = MegaBytes 0
mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b)