From 5462723243355c387746b10298db747d95e3e2c9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 15:53:00 -0700 Subject: working on parted --- debian/changelog | 7 ++ propellor.cabal | 2 + src/Propellor/Property/DiskImage.hs | 50 ++++++++++++++ src/Propellor/Property/Parted.hs | 129 ++++++++++++++++++++++++++++++++++++ 4 files changed, 188 insertions(+) create mode 100644 src/Propellor/Property/DiskImage.hs create mode 100644 src/Propellor/Property/Parted.hs diff --git a/debian/changelog b/debian/changelog index 9df4e6a1..45e80047 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +propellor (2.7.3) UNRELEASED; urgency=medium + + * Added Propellor.Property.Parted, for disk partitioning. + * Added Propellor.Property.DiskImage, for bootable disk image creation. + + -- Joey Hess Tue, 25 Aug 2015 13:45:39 -0700 + propellor (2.7.2) unstable; urgency=medium * Added Propellor.Property.ConfFile, with support for Windows-style .ini diff --git a/propellor.cabal b/propellor.cabal index d0d1c362..d07684b1 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -78,6 +78,7 @@ Library Propellor.Property.ConfFile Propellor.Property.Cron Propellor.Property.Debootstrap + Propellor.Property.DiskImage Propellor.Property.Dns Propellor.Property.DnsSec Propellor.Property.Docker @@ -94,6 +95,7 @@ Library Propellor.Property.Obnam Propellor.Property.OpenId Propellor.Property.OS + Propellor.Property.Parted Propellor.Property.Postfix Propellor.Property.Prosody Propellor.Property.Reboot diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs new file mode 100644 index 00000000..15108249 --- /dev/null +++ b/src/Propellor/Property/DiskImage.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.DiskImage ( + built, + DiskImageConfig(..), + DiskImageFinalization, + grubBooted, +) where + +import Propellor +import Propellor.Property.Chroot +import Utility.DataUnits +import Data.Monoid + +-- | Creates a bootable disk image. +-- +-- First the specified Chroot is set up, then a disk image is created, +-- large enough to fit the chroot, which is copied into it. Finally, the +-- DiskImageFinalization property is satisfied to make the disk image +-- bootable. +-- +-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.DefaultConfig d +-- > & Apt.installed ["openssh-server"] +-- > & Grub.installed Grub.PC +-- > & ... +-- > in DiskImage.built mempty chroot DiskImage.grubBooted +built :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty +built c = undefined + +data DiskImageConfig = DiskImageConfig + { freeSpace :: ByteSize -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. + } + +instance Monoid DiskImageConfig where + -- | Default value is 256 mb freeSpace. + mempty = DiskImageConfig (1024 * 1024 * 256) + mappend a b = a + { freeSpace = freeSpace a + freeSpace b + } + +-- | 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 + +-- | Makes grub be the boot loader of the disk image. +-- +-- This does not cause grub to be installed. Use `Grub.installed` when +-- setting up the Chroot to do that. +grubBooted :: DiskImageFinalization +grubBooted = undefined diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs new file mode 100644 index 00000000..3a927354 --- /dev/null +++ b/src/Propellor/Property/Parted.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Parted ( + TableType(..), + PartTable(..), + PartType(..), + FsType, + PartFlag(..), + Eep(..), + partitioned, + parted, + installed, +) where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Utility.DataUnits +import Data.Char + +class PartedVal a where + val :: a -> String + +-- | Types of partition tables supported by parted. +data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN + deriving (Show) + +instance PartedVal TableType where + val = map toLower . show + +-- | A disk's partition table. +data PartTable = PartTable TableType [Partition] + deriving (Show) + +instance Monoid PartTable where + -- | default TableType is MSDOS + mempty = PartTable MSDOS [] + -- | uses the TableType of the second parameter + mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) + +-- | A partition on the disk. +data Partition = Partition + { partType :: PartType + , partFs :: FsType + , partSize :: ByteSize + , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) + , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) + } + deriving (Show) + +-- | Type of a partition. +data PartType = Primary | Logical | Extended + deriving (Show) + +instance PartedVal PartType where + val Primary = "primary" + val Logical = "logical" + val Extended = "extended" + +-- | Eg, "ext4" or "fat16" or "ntfs" or "hfs+" or "linux-swap" +type FsType = String + +-- | Flags that can be set on a partition. +data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag + deriving (Show) + +instance PartedVal PartFlag where + val BootFlag = "boot" + val RootFlag = "root" + val SwapFlag = "swap" + val HiddenFlag = "hidden" + val RaidFlag = "raid" + val LvmFlag = "lvm" + val LbaFlag = "lba" + val LegacyBootFlag = "legacy_boot" + val IrstFlag = "irst" + val EspFlag = "esp" + val PaloFlag = "palo" + +instance PartedVal Bool where + val True = "on" + val False = "off" + +data Eep = YesReallyDeleteDiskContents + +-- | Partitions a disk using parted. Does not mkfs filesystems. +-- +-- The FilePath can be a disk device (eg, /dev/sda), or a disk image file. +-- +-- This deletes any existing partitions in the disk! Use with EXTREME caution! +partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo +partitioned eep disk (PartTable tabletype parts) = + parted eep disk (concat (setunits : mklabel : mkparts (1 :: Integer) 0 parts [])) + `describe` (disk ++ " partitioned") + where + mklabel = ["mklabel", val tabletype] + mkflag partnum (f, b) = + [ "set" + , show partnum + , val f + , val b + ] + setunits = ["unit", "B"] + mkpart partnum offset p = + [ "mkpart" + , show partnum + , val (partType p) + , partFs p + , show offset + , show (offset + partSize p) + ] ++ case partName p of + Just n -> ["name", show partnum, n] + Nothing -> [] + mkparts partnum offset (p:ps) c = + mkparts (partnum+1) (offset + partSize p) ps + (c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p)) + mkparts _ _ [] c = c + +-- | Runs parted on a disk with the specified parameters. +-- +-- Parted is run in script mode, so it will never prompt for input. +-- It is asked to use optimal alignment for the disk, for best performance. +parted :: Eep -> FilePath -> [String] -> Property NoInfo +parted YesReallyDeleteDiskContents disk ps = + cmdProperty "parted" ("--script":"--align":"optimal":disk:ps) + `requires` installed + +-- | Gets parted installed. +installed :: Property NoInfo +installed = Apt.installed ["parted"] -- cgit v1.2.3