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.hs114
1 files changed, 87 insertions, 27 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index cb373c94..5bdd8f1a 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -3,56 +3,116 @@
module Propellor.Property.DiskImage (
built,
rebuilt,
- DiskImageConfig(..),
+ MountPoint,
+ MkPartTable,
+ fitChrootSize,
+ freeSpace,
DiskImageFinalization,
grubBooted,
+ Grub.BIOS(..),
) where
import Propellor
import Propellor.Property.Chroot
import Propellor.Property.Parted
+import qualified Propellor.Property.Grub as Grub
+
+import qualified Data.Map.Strict as M
+import System.Posix.Files
-- | Creates a bootable disk image.
--
-- First the specified Chroot is set up, and its properties are satisfied.
--- Then a disk image is created, large enough to fit the chroot, which
--- is copied into it. Finally, the DiskImageFinalization property is
+--
+-- 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.
--
-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
--- > & Apt.installed ["openssh-server"]
--- > & Grub.installed Grub.PC
--- > & ...
--- > in DiskImage.built mempty chroot DiskImage.grubBooted
-built :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+-- > & Apt.installed ["openssh-server"]
+-- > & ...
+-- > 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
-- | 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 :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+rebuilt :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
rebuilt = built' True
-built' :: Bool -> DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
-built' rebuild c mkchroot final = undefined
+built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
+built' rebuild mkparttable mkchroot final = undefined
-data DiskImageConfig = DiskImageConfig
- { freeSpace :: MegaBytes -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. (mempty default: 256 Megabytes)
- }
+-- TODO tie the knot
+-- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)]
+-- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts)
-instance Monoid DiskImageConfig where
- mempty = DiskImageConfig (MegaBytes 256)
- mappend a b = a
- { freeSpace = freeSpace a <> freeSpace b
- }
+-- | Generates a map of the sizes of the contents of
+-- every directory in a filesystem tree.
+--
+-- Should be same values as du -b
+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
+ s <- getSymbolicLinkStatus i
+ let sz = fromIntegral (fileSize s)
+ if isDirectory s
+ then do
+ subm <- go M.empty i =<< dirContents i
+ let sz' = M.foldr' (+) sz
+ (M.filterWithKey (const . subdirof i) subm)
+ go (M.insertWith (+) i sz' (M.union m subm)) dir is
+ else go (M.insertWith (+) dir sz m) dir is
+ subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
--- | This is a property that is run, chrooted into the disk image. It's
--- typically only used to set up the boot loader.
-type DiskImageFinalization = Property NoInfo
+-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.
+type MountPoint = Maybe FilePath
--- | Makes grub be the boot loader of the disk image.
+-- | 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.
--
--- This does not cause grub to be installed. Use `Grub.installed` when
--- setting up the Chroot to do that.
-grubBooted :: DiskImageFinalization
-grubBooted = undefined
+-- (Partitions that are not mounted (ie, LinuxSwap) 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
+ (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)
+
+-- | Makes grub be the boot loader of the disk image.
+grubBooted :: Grub.BIOS -> DiskImageFinalization
+grubBooted bios = (Grub.installed bios, undefined)