1 files changed, 181 insertions, 0 deletions
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
new file mode 100644
index 00000000..aa7bece4
--- /dev/null
+++ b/src/Propellor/Property/Parted.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Propellor.Property.Parted (
+	TableType(..),
+	PartTable(..),
+	Partition(..),
+	mkPartition,
+	Partition.Fs(..),
+	MegaBytes(..),
+	ByteSize,
+	toMegaBytes,
+	Partition.MkfsOpts,
+	PartType(..),
+	PartFlag(..),
+	Eep(..),
+	partitioned,
+	parted,
+	installed,
+) where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Partition as Partition
+import Utility.DataUnits
+import Data.Char
+import System.Posix.Files
+
+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
+	, partSize :: MegaBytes
+	, partFs :: Partition.Fs
+	, partMkFsOpts :: Partition.MkfsOpts
+	, 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)
+
+-- | Makes a Partition with defaults for non-important values.
+mkPartition :: Partition.Fs -> MegaBytes -> Partition
+mkPartition fs sz = Partition
+	{ partType = Primary
+	, partSize = sz
+	, partFs = fs
+	, partMkFsOpts = []
+	, partFlags = []
+	, partName = Nothing
+	}
+
+-- | Type of a partition.
+data PartType = Primary | Logical | Extended
+	deriving (Show)
+
+instance PartedVal PartType where
+	val Primary = "primary"
+	val Logical = "logical"
+	val Extended = "extended"
+
+-- | All partition sizing is done in megabytes, so that parted can
+-- automatically lay out the partitions.
+--
+-- Note that these are SI megabytes, not mebibytes.
+newtype MegaBytes = MegaBytes Integer
+	deriving (Show)
+
+instance PartedVal MegaBytes where
+	val (MegaBytes n) = show n ++ "MB"
+
+toMegaBytes :: ByteSize -> MegaBytes
+toMegaBytes b = MegaBytes (b `div` 1000000)
+
+instance Monoid MegaBytes where
+	mempty = MegaBytes 0
+	mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b)
+
+-- | 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"
+
+instance PartedVal Partition.Fs where
+	val Partition.EXT2 = "ext2"
+	val Partition.EXT3 = "ext3"
+	val Partition.EXT4 = "ext4"
+	val Partition.BTRFS = "btrfs"
+	val Partition.REISERFS = "reiserfs"
+	val Partition.XFS = "xfs"
+	val Partition.FAT = "fat"
+	val Partition.VFAT = "vfat"
+	val Partition.NTFS = "ntfs"
+	val Partition.LinuxSwap = "linux-swap"
+
+data Eep = YesReallyDeleteDiskContents
+
+-- | Partitions a disk using parted, and formats the partitions.
+--
+-- The FilePath can be a block 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) = property desc $ do
+	isdev <- liftIO $ isBlockDevice <$> getFileStatus disk
+	ensureProperty $ if isdev
+		then go (map (\n -> disk ++ show n) [1 :: Int ..])
+		else Partition.kpartx disk go
+  where
+	desc = disk ++ " partitioned"
+	go devs = combineProperties desc $
+		parted eep disk partedparams : map format (zip parts devs)
+	partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts []
+	format (p, dev) = Partition.formatted' (partMkFsOpts p)
+		Partition.YesReallyFormatPartition (partFs p) dev
+	mklabel = ["mklabel", val tabletype]
+	mkflag partnum (f, b) =
+		[ "set"
+		, show partnum
+		, val f
+		, val b
+		]
+	mkpart partnum offset p =
+		[ "mkpart"
+		, val (partType p)
+		, val (partFs p)
+		, val offset
+		, val (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 cylinder alignment for the disk.
+parted :: Eep -> FilePath -> [String] -> Property NoInfo
+parted YesReallyDeleteDiskContents disk ps = 
+	cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
+		`requires` installed
+
+-- | Gets parted installed.
+installed :: Property NoInfo
+installed = Apt.installed ["parted"]