Merge branch 'joeyconfig'

7 files changed, 312 insertions, 2 deletions

diff --git a/config-joey.hs b/config-joey.hs
index acb20112..71b1a4ae 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -34,7 +34,7 @@ import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuil
 import qualified Propellor.Property.SiteSpecific.IABak as IABak
 import qualified Propellor.Property.SiteSpecific.Branchable as Branchable
 import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
-
+import Propellor.Property.Parted
 
 main :: IO ()           --     _         ______`|                       ,-.__ 
 main = defaultMain hosts --  /   \___-=O`/|O`/__|                      (____.'
@@ -80,6 +80,9 @@ darkstar = host "darkstar.kitenet.net"
 	& JoeySites.postfixClientRelay (Context "darkstar.kitenet.net")
 	& JoeySites.dkimMilter
 
+	& partitioned YesReallyDeleteDiskContents "/home/joey/disk"
+		(PartTable MSDOS [ mkPartition EXT3 (MegaBytes 256), mkPartition LinuxSwap (MegaBytes 16)])
+
 gnu :: Host
 gnu = host "gnu.kitenet.net"
 	& Apt.buildDep ["git-annex"] `period` Daily
diff --git a/debian/changelog b/debian/changelog
index 9df4e6a1..214038c3 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,11 @@
+propellor (2.7.3) UNRELEASED; urgency=medium
+
+  * Added Propellor.Property.Parted, for disk partitioning.
+  * Added Propellor.Property.Partition, for partition formatting etc.
+  * 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..329739be 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,8 @@ Library
     Propellor.Property.Obnam
     Propellor.Property.OpenId
     Propellor.Property.OS
+    Propellor.Property.Parted
+    Propellor.Property.Partition
     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..cb373c94
--- /dev/null
+++ b/src/Propellor/Property/DiskImage.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Propellor.Property.DiskImage (
+	built,
+	rebuilt,
+	DiskImageConfig(..),
+	DiskImageFinalization,
+	grubBooted,
+) where
+
+import Propellor
+import Propellor.Property.Chroot
+import Propellor.Property.Parted
+
+-- | Creates a bootable disk image.
+--
+-- First the specified Chroot is set up, and its properties are satisfied.
+-- 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") mempty d
+-- > 	& Apt.installed ["openssh-server"]
+-- >	& Grub.installed Grub.PC
+-- >	& ...
+-- > in DiskImage.built mempty chroot DiskImage.grubBooted
+built :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+built = built' 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.
+rebuilt :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+rebuilt = built' True
+
+built' :: Bool -> DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+built' rebuild c mkchroot final = undefined
+
+data DiskImageConfig = DiskImageConfig
+	{ freeSpace :: MegaBytes -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. (mempty default: 256 Megabytes)
+	}
+
+instance Monoid DiskImageConfig where
+	mempty = DiskImageConfig (MegaBytes 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/Mount.hs b/src/Propellor/Property/Mount.hs
index ff47f4d9..43ca0cc6 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -3,7 +3,8 @@ module Propellor.Property.Mount where
 import Propellor
 import Utility.Path
 
-type FsType = String
+type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect)
+
 type Source = String
 
 -- | Lists all mount points of the system.
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"]
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
new file mode 100644
index 00000000..41bdf795
--- /dev/null
+++ b/src/Propellor/Property/Partition.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Propellor.Property.Partition where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+
+-- | Filesystems etc that can be used for a partition.
+data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
+	deriving (Show)
+
+data Eep = YesReallyFormatPartition
+
+-- | Formats a partition.
+formatted :: Eep -> Fs -> FilePath -> Property NoInfo
+formatted = formatted' []
+
+-- | Options passed to a mkfs.* command when making a filesystem.
+--
+-- Eg, ["-m0"]
+type MkfsOpts = [String]
+
+formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo
+formatted' opts YesReallyFormatPartition fs dev = 
+	cmdProperty cmd opts' `requires` Apt.installed [pkg]
+  where
+	(cmd, opts', pkg) = case fs of
+		EXT2 -> ("mkfs.ext2", optsdev, "e2fsprogs")
+		EXT3 -> ("mkfs.ext3", optsdev, "e2fsprogs")
+		EXT4 -> ("mkfs.ext4", optsdev, "e2fsprogs")
+		BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools")
+		REISERFS -> ("mkfs.reiserfs", optsdev, "reiserfsprogs")
+		XFS -> ("mkfs.xfs", optsdev, "xfsprogs")
+		FAT -> ("mkfs.fat", optsdev, "dosfstools")
+		VFAT -> ("mkfs.vfat", optsdev, "dosfstools")
+		NTFS -> ("mkfs.ntfs", optsdev, "ntfs-3g")
+		LinuxSwap -> ("mkswap", optsdev, "util-linux")
+	optsdev = opts++[dev]
+
+-- | Uses the kpartx utility to create device maps for partitions contained
+-- within a disk image file. The resulting devices are passed to the
+-- property, which can operate on them. Always cleans up after itself,
+-- by removing the device maps after the property is run.
+kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo
+kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
+  where
+	go = property (propertyDesc (mkprop [])) $ do
+		cleanup -- idempotency
+		s <- liftIO $ readProcess "kpartx" ["-avs", diskimage]
+		r <- ensureProperty (mkprop (devlist s))
+		cleanup
+		return r
+	devlist = mapMaybe (finddev . words) . lines
+	finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s)
+	finddev _ = Nothing
+	cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]