summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog7
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Property/DiskImage.hs50
-rw-r--r--src/Propellor/Property/Parted.hs129
4 files changed, 188 insertions, 0 deletions
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 <id@joeyh.name> 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"]