From e85a15d160005929a9d5ea5cb21c25751856c5ae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Sep 2015 11:09:50 -0700 Subject: keystone for disk image creation Untested, and grub booting not done. --- src/Propellor/Property/Parted.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'src/Propellor/Property/Parted.hs') 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) -- cgit v1.3-2-g0d8e From e63158e270129b39b19a58b9952b9235570a393d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:27:25 -0700 Subject: run parted before kpartex --- src/Propellor/Property/Parted.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'src/Propellor/Property/Parted.hs') diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 4e2efe24..fcff089a 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -147,13 +147,15 @@ data Eep = YesReallyDeleteDiskContents partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo partitioned eep disk (PartTable tabletype parts) = property desc $ do isdev <- liftIO $ isBlockDevice <$> getFileStatus disk - ensureProperty $ if isdev - then go (map (\n -> disk ++ show n) [1 :: Int ..]) - else Partition.kpartx disk go + ensureProperty $ combineProperties desc + [ parted eep disk partedparams + , if isdev + then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) + else Partition.kpartx disk formatl + ] where desc = disk ++ " partitioned" - go devs = combineProperties desc $ - parted eep disk partedparams : map format (zip parts devs) + formatl devs = combineProperties desc (map format (zip parts devs)) partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev -- cgit v1.3-2-g0d8e From 418e6a5b4ee36360911cdff14f70357c5c2bfc80 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:09:47 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 36 +++++++++++++++++++++++++++--------- src/Propellor/Property/Parted.hs | 4 ++++ 2 files changed, 31 insertions(+), 9 deletions(-) (limited to 'src/Propellor/Property/Parted.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 59baa8d1..86be3a9b 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -33,6 +33,7 @@ import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File 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 @@ -85,13 +86,12 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir - szm <- liftIO $ M.mapKeys (toSysDir chrootdir) . M.map toPartSize - <$> dirSizes chrootdir + szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize + <$> liftIO (dirSizes chrootdir) -- tie the knot! - -- TODO when /boot is in part table, size of / - -- should be reduced by sie of /boot -- TODO if any size is < 1 MB, use 1 MB for sanity - let (mnts, t) = mkparttable (map (getMountSz szm) mnts) + let (mnts, t) = mkparttable (map (saneSz . fromMaybe defSz . getMountSz szm mnts) mnts) + liftIO $ print (mnts, t) ensureProperty $ imageExists img (partTableSize t) `before` @@ -140,6 +140,23 @@ 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 @@ -162,10 +179,11 @@ mountedAt mkp mntpoint = (Just mntpoint, mkp) swapPartition :: PartSize -> PartSpec swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) -getMountSz :: (M.Map FilePath PartSize) -> MountPoint -> PartSize -getMountSz _ Nothing = defSz -getMountSz szm (Just mntpt) = M.findWithDefault defSz mntpt szm - +-- | Avoid partitions smaller than 1 mb; parted gets confused. +saneSz :: PartSize -> PartSize +saneSz (MegaBytes n) | n < 1 = MegaBytes 1 +saneSz sz = sz + defSz :: PartSize defSz = MegaBytes 128 diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index fcff089a..1ff8677a 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -11,6 +11,7 @@ module Propellor.Property.Parted ( ByteSize, toPartSize, fromPartSize, + reducePartSize, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -104,6 +105,9 @@ instance Monoid PartSize where mempty = MegaBytes 0 mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) +reducePartSize :: PartSize -> PartSize -> PartSize +reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b) + -- | Flags that can be set on a partition. data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag deriving (Show) -- cgit v1.3-2-g0d8e From fe59ea1a62ff8dd15e30646802b9ca045df3008b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:23:47 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 4 ++-- src/Propellor/Property/Parted.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) (limited to 'src/Propellor/Property/Parted.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 86be3a9b..1d087cc0 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -88,9 +88,9 @@ imageBuilt' rebuild img mkchroot mkparttable final = liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) + let calcsz = \mnts -> saneSz . fromMaybe defSz . getMountSz szm mnts -- tie the knot! - -- TODO if any size is < 1 MB, use 1 MB for sanity - let (mnts, t) = mkparttable (map (saneSz . fromMaybe defSz . getMountSz szm mnts) mnts) + let (mnts, t) = mkparttable (map (calcsz mnts) mnts) liftIO $ print (mnts, t) ensureProperty $ imageExists img (partTableSize t) diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 1ff8677a..0b77fad1 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -95,8 +95,9 @@ newtype PartSize = MegaBytes Integer instance PartedVal PartSize where val (MegaBytes n) = show n ++ "MB" +-- | Rounds up to the nearest MegaByte. toPartSize :: ByteSize -> PartSize -toPartSize b = MegaBytes (b `div` 1000000) +toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double) fromPartSize :: PartSize -> ByteSize fromPartSize (MegaBytes b) = b * 1000000 -- cgit v1.3-2-g0d8e From 55b925a6e0e5a27a964d9b80cd64d519cda7ae3d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 07:21:49 -0700 Subject: partition setup dsl --- config-joey.hs | 11 ++-- src/Propellor/Property/DiskImage.hs | 128 ++++++++++++++++++------------------ src/Propellor/Property/Parted.hs | 6 +- 3 files changed, 75 insertions(+), 70 deletions(-) (limited to 'src/Propellor/Property/Parted.hs') diff --git a/config-joey.hs b/config-joey.hs index bfd14d7e..75150184 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -80,15 +80,14 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter - & imageBuilt "/tmp/img" c ps noFinalization -- (grubBooted PC) + & imageBuilt "/tmp/img" c MSDOS + [ mkPartition EXT2 `setFlag` BootFlag `mountedAt` "/boot" + , mkPartition EXT4 `addFreeSpace` MegaBytes 100 `mountedAt` "/" + , swapPartition (MegaBytes 256) + ] noFinalization -- (grubBooted PC) where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] - ps = fitChrootSize MSDOS - [ mkPartition EXT2 `mountedAt` "/boot" - , mkPartition EXT4 `mountedAt` "/" - , swapPartition (MegaBytes 256) - ] gnu :: Host gnu = host "gnu.kitenet.net" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 8ee77376..4ef8d1a4 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | Disk image generation. -- -- This module is designed to be imported unqualified. @@ -11,27 +9,23 @@ module Propellor.Property.DiskImage ( imageRebuilt, imageBuiltFrom, imageExists, - -- * Partition specifiction - MountPoint, + -- * Partitioning + Partition, + MkPartition, + mkPartition, + PartSize(..), + Fs(..), PartSpec, + MountPoint, mountedAt, swapPartition, - TableType(..), - PartTable(..), - Partition(..), - mkPartition, - Fs(..), - PartSize(..), - ByteSize, - toPartSize, - fromPartSize, - reducePartSize, - PartType(..), + addFreeSpace, + setSize, PartFlag(..), - -- * Partition sizing - SizePartTable, - fitChrootSize, - freeSpace, + setFlag, + TableType(..), + extended, + adjustp, -- * Finalization Finalization, grubBooted, @@ -70,24 +64,23 @@ type DiskImage = FilePath -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d -- > & Apt.installed ["linux-image-amd64"] -- > & ... --- > partitions = fitChrootSize MSDOS --- > [ mkPartition EXT2 `mountedAt` "/boot" --- > , mkPartition EXT4 `mountedAt` "/" +-- > in imageBuilt "/srv/images/foo.img" chroot MSDOS +-- > [ mkPartition EXT2 `setFlag` BootFlag `mountedAt` "/boot" +-- > , mkPartition EXT4 `addFreeSpace` MegaBytes 100 `mountedAt` "/" -- > , swapPartition (MegaBytes 256) --- > ] --- > in imageBuilt "/srv/images/foo.img" chroot partitions (grubBooted PC) -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +-- > ] (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. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty -imageBuilt' rebuild img mkchroot mkparttable final = - imageBuiltFrom img chrootdir mkparttable (snd final) +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 @@ -111,8 +104,8 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- -- TODO copy in -- TODO run final -imageBuiltFrom :: DiskImage -> FilePath -> SizePartTable -> Property NoInfo -> RevertableProperty -imageBuiltFrom img chrootdir mkparttable final = mkimg rmimg +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 @@ -120,10 +113,9 @@ imageBuiltFrom img chrootdir mkparttable final = mkimg rmimg liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) - let calcsz = \mnts -> saneSz . fromMaybe defSz . getMountSz szm mnts + let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts -- tie the knot! - let (mnts, t) = mkparttable (map (calcsz mnts) mnts) - liftIO $ print (mnts, t) + let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts) ensureProperty $ imageExists img (partTableSize t) `before` @@ -149,8 +141,9 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do return MadeChange -- | Generates a map of the sizes of the contents of --- every directory in a filesystem tree. (Hard links are counted multiple --- times for simplicity) +-- every directory in a filesystem tree. +-- +-- (Hard links are counted multiple times for simplicity) -- -- Should be same values as du -bl dirSizes :: FilePath -> IO (M.Map FilePath Integer) @@ -196,52 +189,61 @@ toSysDir chrootdir d = case makeRelative chrootdir d of -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath +-- | A constructor for a Partition that has not yet been provided with a size. +-- +-- 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 to be mounted (ie, LinuxSwap), or that have +-- no corresponding directory in the chroot will have 128 MegaBytes +-- provided as a default size.) +type MkPartition = PartSize -> Partition + +defSz :: PartSize +defSz = MegaBytes 128 + -- | Specifies a mount point and a constructor for a Partition --- that will later be privided with a size. -type PartSpec = (MountPoint, PartSize -> Partition) +-- that will later be provided with a size. +type PartSpec = (MountPoint, MkPartition) -- | Specifies a mounted partition using a given filesystem. -mountedAt :: (PartSize -> Partition) -> FilePath -> PartSpec +mountedAt :: MkPartition -> FilePath -> PartSpec mountedAt mkp mntpoint = (Just mntpoint, mkp) -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) --- | Avoid partitions smaller than 1 mb; parted gets confused. -saneSz :: PartSize -> PartSize -saneSz (MegaBytes n) | n < 1 = MegaBytes 1 -saneSz sz = sz +-- | Adds additional free space to the partition. +addFreeSpace :: MkPartition -> PartSize -> MkPartition +addFreeSpace mkp freesz = \sz -> mkp (sz <> freesz) -defSz :: PartSize -defSz = MegaBytes 128 +-- | Forced a partition to be a specific size, instead of scaling to the +-- size needed for the files in the chroot. +setSize :: MkPartition -> PartSize -> MkPartition +setSize mkp sz = const (mkp sz) --- | 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 to be mounted (ie, LinuxSwap), or that have --- no corresponding directory in the chroot will have 128 MegaBytes --- provided as a default size.) -type SizePartTable = [PartSize] -> ([MountPoint], PartTable) +-- | Sets a flag on the partition. +setFlag :: MkPartition -> PartFlag -> MkPartition +setFlag mkp f = adjustp mkp $ \p -> p { partFlags = (f, True):partFlags p } + +-- | Makes a MSDOS partition be Extended, rather than Primary. +extended :: MkPartition -> MkPartition +extended mkp = adjustp mkp $ \p -> p { partType = Extended } + +-- | Apply a Partition adjustment to a MkPartition. +adjustp :: MkPartition -> (Partition -> Partition) -> MkPartition +adjustp mkp f = f . mkp -- | The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> SizePartTable +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)] -> SizePartTable -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 diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 0b77fad1..a4f0f98e 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -93,7 +93,11 @@ newtype PartSize = MegaBytes Integer deriving (Show) instance PartedVal PartSize where - val (MegaBytes n) = show n ++ "MB" + val (MegaBytes n) + | n > 0 = show n ++ "MB" + -- parted can't make partitions smaller than 1MB; + -- avoid failure in edge cases + | otherwise = show "1MB" -- | Rounds up to the nearest MegaByte. toPartSize :: ByteSize -> PartSize -- cgit v1.3-2-g0d8e