summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2017-11-19 15:21:53 -0400
committerJoey Hess2017-11-19 15:21:53 -0400
commitc7a8c812add892eb7f7b7068d258efa01095fcde (patch)
treeff9100d6847b8f8007beec8761e48e5875eae53a /src
parent143996429e594def4c31d1346713433335758128 (diff)
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.
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/DiskImage.hs61
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs129
-rw-r--r--src/Propellor/Property/Machine.hs53
-rw-r--r--src/Propellor/Types/PartSpec.hs6
4 files changed, 216 insertions, 33 deletions
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