From c7a8c812add892eb7f7b7068d258efa01095fcde Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 19 Nov 2017 15:21:53 -0400 Subject: partition table in Info Diskimage.imageBuiltFor: New property to build a disk image for a Host, using partition table information configured via the new properties hasPartitionTableType, hasPartition and adjustPartition. This lets Machine properties include eg /boot partitions that are known to be needed by the bootloader, and the user can adjust those partitions and add others. This commit was sponsored by Brock Spratlen on Patreon. --- debian/changelog | 3 + .../Host_could_have_partition_table_in_Info.mdwn | 2 + joeyconfig.hs | 25 ++-- src/Propellor/Property/DiskImage.hs | 61 +++++++--- src/Propellor/Property/DiskImage/PartSpec.hs | 129 +++++++++++++++++++-- src/Propellor/Property/Machine.hs | 53 +++++++-- src/Propellor/Types/PartSpec.hs | 6 + 7 files changed, 236 insertions(+), 43 deletions(-) diff --git a/debian/changelog b/debian/changelog index f7bc48c3..2b41af51 100644 --- a/debian/changelog +++ b/debian/changelog @@ -5,6 +5,9 @@ propellor (5.0.0) UNRELEASED; urgency=medium * Machine: New module collecting machine-specific properties for building bootable images for ARM boards. Tested working boards: Olimex Lime, CubieTruck, Banana Pi, SheevaPlug. + * Diskimage.imageBuiltFor: New property to build a disk image for a Host, + using partition table information configured via the new properties + hasPartitionTableType, hasPartition and adjustPartition. * Chroot.noServices moved to Service.noServices and its type changed. (API change) * Service: Avoid starting services when noServices is used. diff --git a/doc/todo/Host_could_have_partition_table_in_Info.mdwn b/doc/todo/Host_could_have_partition_table_in_Info.mdwn index 5ca20cc7..ed7022f7 100644 --- a/doc/todo/Host_could_have_partition_table_in_Info.mdwn +++ b/doc/todo/Host_could_have_partition_table_in_Info.mdwn @@ -3,3 +3,5 @@ specified separately. However, Propellor.Property.Machine often knows things about the partition table (eg that there needs to be a separate EXT2 /boot partition). So, why not let properties put something in Info and let the partition table be derived from that. --[[Joey]] + +> [[done]] --[[Joey]] diff --git a/joeyconfig.hs b/joeyconfig.hs index 20a34ba9..75762930 100644 --- a/joeyconfig.hs +++ b/joeyconfig.hs @@ -97,16 +97,9 @@ darkstar = host "darkstar.kitenet.net" $ props & Ssh.userKeys (User "joey") hostContext [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - & imageBuilt (RawDiskImage "/srv/honeybee.img") - (hostChroot honeybee (Debootstrapped mempty)) - MSDOS - [ partition EXT2 - `mountedAt` "/boot" - `setSize` MegaBytes 200 - , partition EXT4 - `mountedAt` "/" - `addFreeSpace` MegaBytes 500 - ] + & imageBuiltFor honeybee + (RawDiskImage "/srv/honeybee.img") + (Debootstrapped mempty) gnu :: Host gnu = host "gnu.kitenet.net" $ props @@ -189,6 +182,18 @@ honeybee = host "honeybee.kitenet.net" $ props [ "Home router and arm git-annex build box." ] & cubietech_Cubietruck + & hasPartition + ( partition EXT2 + `mountedAt` "/boot" + `partLocation` Beginning + `setSize` MegaBytes 200 + ) + & hasPartition + ( partition EXT4 + `mountedAt` "/" + `addFreeSpace` MegaBytes 500 + ] + & Apt.installed ["firmware-brcm80211"] -- Workaround for https://bugs.debian.org/844056 `requires` File.hasPrivContent "/lib/firmware/brcm/brcmfmac43362-sdio.txt" anyContext diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 2c35b532..3c6eda09 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -13,6 +13,8 @@ module Propellor.Property.DiskImage ( VirtualBoxPointer(..), imageBuilt, imageRebuilt, + imageBuiltFor, + imageRebuiltFor, imageBuiltFrom, imageExists, Grub.BIOS(..), @@ -134,36 +136,59 @@ instance DiskImage VirtualBoxPointer where -- > & User.hasPassword (User "demo") -- > & User.hasDesktopGroups (User "demo") -- > & ... +imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt = imageBuilt' False + +-- | Like 'imageBuilt', 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 d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageRebuilt = imageBuilt' True + +-- | Create a bootable disk image for a Host. +-- +-- This works just like 'imageBuilt', but partition table is +-- determined by looking at the Host's 'hasPartitionTableType' +-- `hasPartition', and 'adjustPartition' properties. -- --- This can also be used with `Chroot.hostChroot` to build a disk image --- that has all the properties of a Host. For example: +-- For example: -- -- > foo :: Host -- > foo = host "foo.example.com" $ props --- > & imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img") --- > (hostChroot bar (Debootstrapped mempty)) --- > MSDOS --- > [ partition EXT2 `mountedAt` "/boot" --- > `setFlag` BootFlag --- > , partition EXT4 `mountedAt` "/" --- > `addFreeSpace` MegaBytes 5000 --- > , swapPartition (MegaBytes 256) --- > ] +-- > & imageBuiltFor bar +-- > (RawDiskImage "/srv/diskimages/bar-disk.img") +-- > (Debootstrapped mempty) -- > -- > bar :: Host -- > bar = host "bar.example.com" $ props +-- > & hasPartiton +-- > ( partition EXT2 +-- > `mountedAt` "/boot" +-- > `partLocation` Beginning +-- > `addFreeSpace` MegaBytes 150 +-- > ) +-- > & hasPartiton +-- > ( partition EXT4 +-- > `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 500 +-- > ) -- > & osDebian Unstable X86_64 -- > & Apt.installed ["linux-image-amd64"] -- > & Grub.installed PC -- > & hasPassword (User "root") -imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux -imageBuilt = imageBuilt' False +imageBuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuiltFor = imageBuiltFor' 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 d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux -imageRebuilt = imageBuilt' True +-- | Like 'imageBuiltFor', but the chroot is deleted and rebuilt from +-- scratch each time. +imageRebuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux +imageRebuiltFor = imageBuiltFor' False + +imageBuiltFor' :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Bool -> Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuiltFor' rebuild h d bs = + imageBuilt' rebuild d (Chroot.hostChroot h bs) tt pil + where + PartTableSpec tt pil = toPartTableSpec (fromInfo (hostInfo h)) imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt' rebuild img mkchroot tabletype partspec = diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs index 405c61b0..6a03c857 100644 --- a/src/Propellor/Property/DiskImage/PartSpec.hs +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -1,19 +1,48 @@ --- | Disk image partition specification and combinators. +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +-- | Disk image partition specification. module Propellor.Property.DiskImage.PartSpec ( - module Propellor.Types.PartSpec, - module Propellor.Property.DiskImage.PartSpec, - module Propellor.Property.Parted.Types, - module Propellor.Property.Partition, + PartSpec, + Fs(..), + PartSize(..), + partition, + -- * PartSpec combinators + swapPartition, + mountedAt, + addFreeSpace, + setSize, + mountOpt, + errorReadonly, + reservedSpacePercentage, + setFlag, + extended, + -- * Partition properties + -- + -- | These properties do not do any disk partitioning on their own, but + -- the Info they set can be used when building a disk image for a + -- host. + hasPartition, + adjustPartition, + PartLocation(..), + partLocation, + hasPartitionTableType, + TableType(..), + PartInfo, + toPartTableSpec, + PartTableSpec(..) ) where import Propellor.Base import Propellor.Property.Parted import Propellor.Types.PartSpec -import Propellor.Property.Parted.Types +import Propellor.Types.Info import Propellor.Property.Partition (Fs(..)) import Propellor.Property.Mount +import Data.List (sortBy) +import Data.Ord + -- | Specifies a partition with a given filesystem. -- -- The partition is not mounted anywhere by default; use the combinators @@ -26,7 +55,7 @@ swapPartition :: Monoid t => PartSize -> PartSpec t swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty) -- | Specifies where to mount a partition. -mountedAt :: PartSpec t -> FilePath -> PartSpec t +mountedAt :: PartSpec t -> MountPoint -> PartSpec t mountedAt (_, o, p, t) mp = (Just mp, o, p, t) -- | Partitions in disk images default to being sized large enough to hold @@ -69,3 +98,89 @@ extended s = adjustp s $ \p -> p { partType = Extended } adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t adjustp (mp, o, p, t) f = (mp, o, f . p, t) + +data PartInfoVal + = TableTypeInfo TableType + | PartSpecInfo (PartSpec PartLocation) + | AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation) + +newtype PartInfo = PartInfo [PartInfoVal] + deriving (Monoid, Typeable) + +instance IsInfo PartInfo where + propagateInfo _ = PropagateInfo False + +instance Show PartInfo where + show = show . toPartTableSpec + +toPartTableSpec :: PartInfo -> PartTableSpec +toPartTableSpec (PartInfo l) = PartTableSpec tt pil + where + tt = fromMaybe MSDOS $ headMaybe $ reverse $ mapMaybe gettt l + + pil = map convert $ sortBy (comparing location) $ adjust collect + collect = mapMaybe getspartspec l + adjust ps = adjust' ps (mapMaybe getadjust l) + adjust' ps [] = ps + adjust' ps ((mp, f):rest) = adjust' (map (adjustone mp f) ps) rest + adjustone mp f p@(mp', _, _, _) + | Just mp == mp' = f p + | otherwise = p + location (_, _, _, loc) = loc + convert (mp, o, p, _) = (mp, o, p, ()) + + gettt (TableTypeInfo t) = Just t + gettt _ = Nothing + getspartspec (PartSpecInfo ps) = Just ps + getspartspec _ = Nothing + getadjust (AdjustPartSpecInfo mp f) = Just (mp, f) + getadjust _ = Nothing + +-- | Indicates the partition table type of a host. +-- +-- When not specified, the default is MSDOS. +-- +-- For example: +-- +-- > & hasPartitionTableType GPT +hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike) +hasPartitionTableType tt = pureInfoProperty + ("partition table type " ++ show tt) + (PartInfo [TableTypeInfo tt]) + +-- | Indicates that a host has a partition. +-- +-- For example: +-- +-- > & hasPartiton (partition EXT2 `mountedAt` "/boot" `partLocation` Beginning) +-- > & hasPartiton (partition EXT4 `mountedAt` "/") +-- > & hasPartiton (partition EXT4 `mountedAt` "/home" `partLocation` End `reservedSpacePercentage` 0) +hasPartition :: PartSpec PartLocation -> Property (HasInfo + UnixLike) +hasPartition p@(mmp, _, _, _) = pureInfoProperty desc + (PartInfo [PartSpecInfo p]) + where + desc = case mmp of + Just mp -> "has " ++ mp ++ " partition" + Nothing -> "has unmounted partition" + +-- | Adjusts the PartSpec for the partition mounted at the specified location. +-- +-- For example: +-- +-- > & adjustPartition "/boot" (`addFreeSpace` MegaBytes 150) +adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike) +adjustPartition mp f = pureInfoProperty + ("has " ++ mp ++ " adjusted") + (PartInfo [AdjustPartSpecInfo mp f]) + +-- | Indicates partition layout in a disk. Default is somewhere in the +-- middle. +data PartLocation = Beginning | Middle | End + deriving (Eq, Ord) + +instance Monoid PartLocation where + mempty = Middle + mappend _ b = b + +partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation +partLocation (mp, o, p, _) l = (mp, o, p, l) diff --git a/src/Propellor/Property/Machine.hs b/src/Propellor/Property/Machine.hs index b4ffc008..ec522c21 100644 --- a/src/Propellor/Property/Machine.hs +++ b/src/Propellor/Property/Machine.hs @@ -17,6 +17,31 @@ -- firmware, but if the non-free firmware is only needed for non-critical -- functionality, it won't be included. +-- | Example: Building a disk image for a Marvell SheevaPlug +-- +-- This defines a Host "sheeva" that is a Marvell SheevaPlug. +-- A bootable disk image for "sheeva" is built on another machine +-- "darkstar", which can be eg an Intel laptop running Debian. +-- +-- > import Propellor.Property.Machine +-- > import Propellor.Property.DiskImage +-- > +-- > sheeva :: Host +-- > sheeva = host "sheeva.example.com" $ props +-- > & osDebian Unstable ARMEL +-- > & marvell_SheevaPlug Marvell_SheevaPlug_SDCard +-- > & hasPartiton +-- > ( partition EXT4 +-- > `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 2048 +-- > ) +-- > +-- > darkstar :: Host +-- > darkstar = host "darkstar.example.com" $ props +-- > & imageBuiltFor sheeva +-- > (RawDiskImage "/srv/sheeva-disk.img") +-- > (Debootstrapped mempty) + module Propellor.Property.Machine ( -- * ARM boards Marvell_SheevaPlug_BootDevice(..), @@ -41,25 +66,37 @@ import Propellor.Types.Core import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.FlashKernel as FlashKernel import qualified Propellor.Property.Uboot as Uboot +import Propellor.Property.DiskImage.PartSpec data Marvell_SheevaPlug_BootDevice = Marvell_SheevaPlug_SDCard | Marvell_SheevaPlug_ESATA --- | Marvel SheevaPlug +-- | Marvell SheevaPlug -- --- Needs a small /boot partition formatted EXT2 +-- This includes a small EXT2 formatted /boot partition. -- -- Note that u-boot may need to be upgraded manually, and will need to be -- configured to boot from the SD card or eSATA. See -- https://www.cyrius.com/debian/kirkwood/sheevaplug/install/ marvell_SheevaPlug :: Marvell_SheevaPlug_BootDevice -> Property (HasInfo + DebianLike) -marvell_SheevaPlug Marvell_SheevaPlug_SDCard = - FlashKernel.installed "Marvell SheevaPlug Reference Board" - `requires` marvell -marvell_SheevaPlug Marvell_SheevaPlug_ESATA = - FlashKernel.installed "Marvell eSATA SheevaPlug Reference Board" - `requires` marvell +marvell_SheevaPlug bd = fk + `requires` marvell + `requires` hasPartition bootpart + where + fk = case bd of + Marvell_SheevaPlug_SDCard -> + FlashKernel.installed "Marvell SheevaPlug Reference Board" + Marvell_SheevaPlug_ESATA -> + FlashKernel.installed "Marvell eSATA SheevaPlug Reference Board" + -- The boot loader needs an EXT2 boot partition, which comes + -- first. Add some free space to allow for additional kernel images + -- and initrds. + bootpart :: PartSpec PartLocation + bootpart = partition EXT2 + `mountedAt` "/boot" + `partLocation` Beginning + `addFreeSpace` MegaBytes 150 -- | Cubietech Cubietruck -- diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs index 860b38f6..c6f9aa7a 100644 --- a/src/Propellor/Types/PartSpec.hs +++ b/src/Propellor/Types/PartSpec.hs @@ -6,3 +6,9 @@ import Propellor.Property.Mount -- | Specifies a mount point, mount options, and a constructor for a -- Partition that determines its size. type PartSpec t = (Maybe MountPoint, MountOpts, PartSize -> Partition, t) + +-- | Specifies a partition table. +data PartTableSpec = PartTableSpec TableType [PartSpec ()] + +instance Show PartTableSpec where + show (PartTableSpec tt _) = "PartTableSpec " ++ show tt -- cgit v1.2.3