summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
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