propellor 2.7.2 → 2.7.3

raw patch · 16 files changed

+618/−26 lines, 16 filesdep ~containers

Dependency ranges changed: containers

Files

• CHANGELOG +12/−0
• README.md +2/−1
• config-joey.hs +10/−1
• debian/changelog +12/−0
• debian/control +1/−1
• doc/README.mdwn +2/−1
• propellor.cabal +7/−4
• src/Propellor/Info.hs +5/−0
• src/Propellor/Property/Chroot/Util.hs +10/−0
• src/Propellor/Property/Debootstrap.hs +2/−9
• src/Propellor/Property/DiskImage.hs +260/−0
• src/Propellor/Property/Mount.hs +8/−1
• src/Propellor/Property/Parted.hs +203/−0
• src/Propellor/Property/Partition.hs +60/−0
• src/Propellor/Property/Systemd.hs +15/−2
• src/Propellor/Shim.hs +9/−6

@@ -1,3 +1,15 @@+propellor (2.7.3) unstable; urgency=medium++  * Fix bug that caused provisioning new chroots to fail.+  * Update for Debian systemd-container package split.+  * Added Propellor.Property.Parted, for disk partitioning.+  * Added Propellor.Property.Partition, for partition formatting etc.+  * Added Propellor.Property.DiskImage, for bootable disk image creation.+    (Experimental and not yet complete.)+  * Dropped support for ghc 7.4.++ -- Joey Hess <id@joeyh.name>  Thu, 03 Sep 2015 08:52:51 -0700+ propellor (2.7.2) unstable; urgency=medium    * Added Propellor.Property.ConfFile, with support for Windows-style .ini

@@ -6,7 +6,8 @@ Propellor is configured via a git repository, which typically lives in `~/.propellor/` on your development machine. Propellor clones the repository to each host it manages, in a -[secure](http://propellor.branchable.com/security/) way. See [[components]]+[secure](http://propellor.branchable.com/security/) way. See +[components](http://propellor.branchable.com/components/) for details.  Properties are defined using Haskell. Edit `~/.propellor/config.hs`

@@ -34,7 +34,7 @@ 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.DiskImage  main :: IO ()           --     _         ______`|                       ,-.__  main = defaultMain hosts --  /   \___-=O`/|O`/__|                      (____.'@@ -79,6 +79,15 @@  	& JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") 	& JoeySites.dkimMilter++	& imageBuilt "/tmp/img" c MSDOS+		[ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag+		, partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100+		, swapPartition (MegaBytes 256)+		] noFinalization -- (grubBooted PC)+  where+	c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d+		& Apt.installed ["linux-image-amd64"]  gnu :: Host gnu = host "gnu.kitenet.net"

@@ -1,3 +1,15 @@+propellor (2.7.3) unstable; urgency=medium++  * Fix bug that caused provisioning new chroots to fail.+  * Update for Debian systemd-container package split.+  * Added Propellor.Property.Parted, for disk partitioning.+  * Added Propellor.Property.Partition, for partition formatting etc.+  * Added Propellor.Property.DiskImage, for bootable disk image creation.+    (Experimental and not yet complete.)+  * Dropped support for ghc 7.4.++ -- Joey Hess <id@joeyh.name>  Thu, 03 Sep 2015 08:52:51 -0700+ propellor (2.7.2) unstable; urgency=medium    * Added Propellor.Property.ConfFile, with support for Windows-style .ini

@@ -4,7 +4,7 @@ Build-Depends:  	debhelper (>= 9), 	git,-	ghc (>= 7.4),+	ghc (>= 7.6), 	cabal-install, 	libghc-async-dev, 	libghc-missingh-dev,

@@ -6,7 +6,8 @@ Propellor is configured via a git repository, which typically lives in `~/.propellor/` on your development machine. Propellor clones the repository to each host it manages, in a -[secure](http://propellor.branchable.com/security/) way. See [[components]]+[secure](http://propellor.branchable.com/security/) way. See +[components](http://propellor.branchable.com/components/) for details.  Properties are defined using Haskell. Edit `~/.propellor/config.hs`

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.7.2+Version: 2.7.3 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -38,7 +38,7 @@   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async, time, QuickCheck, mtl, transformers,+   containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,    exceptions (>= 0.6)    if (! os(windows))@@ -50,7 +50,7 @@   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async, time, QuickCheck, mtl, transformers,+   containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,    exceptions    if (! os(windows))@@ -61,7 +61,7 @@   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async, time, QuickCheck, mtl, transformers,+   containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,    exceptions    if (! os(windows))@@ -78,6 +78,7 @@     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 @@     Propellor.Property.Obnam     Propellor.Property.OpenId     Propellor.Property.OS+    Propellor.Property.Parted+    Propellor.Property.Partition     Propellor.Property.Postfix     Propellor.Property.Prosody     Propellor.Property.Reboot

@@ -18,10 +18,15 @@ askInfo :: (Info -> Val a) -> Propellor (Maybe a) askInfo f = asks (fromVal . f . hostInfo) +-- | Specifies the operating system of a host.+--+-- This only provides info for other Properties, so they can act+-- conditional on the os. os :: System -> Property HasInfo os system = pureInfoProperty ("Operating " ++ show system) $ 	mempty { _os = Val system } +--  Gets the operating system of a host, if it has been specified. getOS :: Propellor (Maybe System) getOS = askInfo _os 

@@ -1,7 +1,10 @@ module Propellor.Property.Chroot.Util where +import Propellor.Property.Mount+ import Utility.Env import Control.Applicative+import System.Directory  -- When chrooting, it's useful to ensure that PATH has all the standard -- directories in it. This adds those directories to whatever PATH is@@ -14,3 +17,10 @@  stdPATH :: String stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"++-- Removes the contents of a chroot. First, unmounts any filesystems+-- mounted within it.+removeChroot :: FilePath -> IO ()+removeChroot c = do+	unmountBelow c+	removeDirectoryRecursive c

@@ -13,7 +13,6 @@ import Propellor import qualified Propellor.Property.Apt as Apt import Propellor.Property.Chroot.Util-import Propellor.Property.Mount import Utility.Path import Utility.FileMode @@ -61,7 +60,7 @@ 	teardown = check (not <$> unpopulated target) teardownprop 	 	teardownprop = property ("removed debootstrapped " ++ target) $-		makeChange (removetarget target)+		makeChange (removeChroot target)  built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) built' installprop target system@(System _ arch) config = @@ -96,19 +95,13 @@ 	-- recover by deleting it and trying again. 	ispartial = ifM (doesDirectoryExist (target </> "debootstrap")) 		( do-			removetarget target+			removeChroot target 			return True 		, return False 		) 	 unpopulated :: FilePath -> IO Bool unpopulated d = null <$> catchDefaultIO [] (dirContents d)	--removetarget :: FilePath -> IO ()-removetarget target = do-	submnts <- mountPointsBelow target-	forM_ submnts umountLazy-	removeDirectoryRecursive target  extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s

@@ -0,0 +1,260 @@+-- | Disk image generation. +--+-- This module is designed to be imported unqualified.++module Propellor.Property.DiskImage (+	-- * Properties+	DiskImage,+	imageBuilt,+	imageRebuilt,+	imageBuiltFrom,+	imageExists,+	-- * Partitioning+	Partition,+	PartSize(..),+	Fs(..),+	PartSpec,+	MountPoint,+	swapPartition,+	partition,+	mountedAt,+	addFreeSpace,+	setSize,+	PartFlag(..),+	setFlag,+	TableType(..),+	extended,+	adjustp,+	-- * Finalization+	Finalization,+	grubBooted,+	Grub.BIOS(..),+	noFinalization,+) where++import Propellor+import Propellor.Property.Chroot (Chroot)+import Propellor.Property.Chroot.Util (removeChroot)+import qualified Propellor.Property.Chroot as Chroot+import qualified Propellor.Property.Grub as Grub+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import Propellor.Property.Parted+import Propellor.Property.Mount+import Utility.Path++import qualified Data.Map.Strict as M+import qualified Data.ByteString.Lazy as L+import System.Posix.Files++type DiskImage = FilePath++-- | Creates a bootable disk image.+--+-- First the specified Chroot is set up, and its properties are satisfied.+--+-- Then, the disk image is set up, and the chroot is copied into the+-- appropriate partition(s) of it.+--+-- Example use:+--+-- > import Propellor.Property.DiskImage+--+-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d+-- > 		& Apt.installed ["linux-image-amd64"]+-- >		& ...+-- > in imageBuilt "/srv/images/foo.img" chroot MSDOS +-- >		[ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag+-- >		, partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100+-- >		, swapPartition (MegaBytes 256)+-- >		] (grubBooted PC)+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty+imageBuilt = imageBuilt' 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 -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty+imageRebuilt = imageBuilt' True++imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty+imageBuilt' rebuild img mkchroot tabletype partspec final = +	imageBuiltFrom img chrootdir tabletype partspec (snd final)+		`requires` Chroot.provisioned chroot+		`requires` (cleanrebuild <!> doNothing)+		`describe` desc+  where+	desc = "built disk image " ++ img+	cleanrebuild+		| rebuild = property desc $ do+			liftIO $ removeChroot chrootdir+			return MadeChange+		| otherwise = doNothing+	chrootdir = img ++ ".chroot"+	chroot = mkchroot chrootdir+		-- First stage finalization.+		& fst final+		-- Avoid wasting disk image space on the apt cache+		& Apt.cacheCleaned++-- | Builds a disk image from the contents of a chroot.+--+-- The passed property is run inside the mounted disk image.+--+-- TODO copy in+-- TODO run final+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty+imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg+  where+	mkimg = property (img ++ " built from " ++ chrootdir) $ do+		-- unmount helper filesystems such as proc from the chroot+		-- before getting sizes+		liftIO $ unmountBelow chrootdir+		szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize +			<$> liftIO (dirSizes chrootdir)+		let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts+		-- tie the knot!+		let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)+		ensureProperty $+			imageExists img (partTableSize t)+				`before`+			partitioned YesReallyDeleteDiskContents img t+	rmimg = File.notPresent img++-- | Ensures that a disk image file of the specified size exists.+-- +-- If the file doesn't exist, or is too small, creates a new one, full of 0's.+--+-- If the file is too large, truncates it down to the specified size.+imageExists :: FilePath -> ByteSize -> Property NoInfo+imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do+	ms <- catchMaybeIO $ getFileStatus img+	case ms of+		Just s +			| toInteger (fileSize s) == toInteger sz -> return NoChange+			| toInteger (fileSize s) > toInteger sz -> do+				setFileSize img (fromInteger sz)+				return MadeChange+		_ -> do+			L.writeFile img (L.replicate (fromIntegral sz) 0)+			return MadeChange++-- | Generates a map of the sizes of the contents of +-- every directory in a filesystem tree. +--+-- (Hard links are counted multiple times for simplicity)+--+-- Should be same values as du -bl+dirSizes :: FilePath -> IO (M.Map FilePath Integer)+dirSizes top = go M.empty top [top]+  where+	go m _ [] = return m+	go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do+		s <- getSymbolicLinkStatus i+		let sz = fromIntegral (fileSize s)+		if isDirectory s+			then do+				subm <- go M.empty i =<< dirContents i+				let sz' = M.foldr' (+) sz +					(M.filterWithKey (const . subdirof i) subm)+				go (M.insertWith (+) i sz' (M.union m subm)) dir is+			else go (M.insertWith (+) dir sz m) dir is+	subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent++-- | Gets the size to allocate for a particular mount point, given the+-- map of sizes.+--+-- A list of all mount points is provided, so that when eg calculating+-- the size for /, if /boot is a mount point, its size can be subtracted.+getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize+getMountSz _ _ Nothing = Nothing+getMountSz szm l (Just mntpt) = +	fmap (`reducePartSize` childsz) (M.lookup mntpt szm)+  where+	childsz = mconcat $ catMaybes $+		map (getMountSz szm l) (filter childmntpt l)+	childmntpt Nothing = False+	childmntpt (Just d) +		| d `equalFilePath` mntpt = False+		| otherwise = mntpt `dirContains` d++-- | From a location in a chroot (eg, /tmp/chroot/usr) to+-- the corresponding location inside (eg, /usr).+toSysDir :: FilePath -> FilePath -> FilePath+toSysDir chrootdir d = case makeRelative chrootdir d of+		"." -> "/"+		sysdir -> "/" ++ sysdir++-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.+type MountPoint = Maybe FilePath++defSz :: PartSize+defSz = MegaBytes 128++-- | Specifies a mount point and a constructor for a Partition.+-- +-- The size that is eventually provided is the amount of space needed to +-- hold the files that appear in the directory where the partition is to be+-- mounted.+--+-- (Partitions that are not to be mounted (ie, LinuxSwap), or that have+-- no corresponding directory in the chroot will have 128 MegaBytes+-- provided as a default size.)+type PartSpec = (MountPoint, PartSize -> Partition)++-- | Specifies a swap partition of a given size.+swapPartition :: PartSize -> PartSpec+swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz))++-- | Specifies a partition with a given filesystem.+--+-- The partition is not mounted anywhere by default; use the combinators+-- below to configure it.+partition :: Fs -> PartSpec+partition fs = (Nothing, mkPartition fs)++-- | Specifies where to mount a partition.+mountedAt :: PartSpec -> FilePath -> PartSpec+mountedAt (_, p) mp = (Just mp, p)++-- | Adds additional free space to the partition.+addFreeSpace :: PartSpec -> PartSize -> PartSpec+addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz))++-- | Forced a partition to be a specific size, instead of scaling to the+-- size needed for the files in the chroot.+setSize :: PartSpec -> PartSize -> PartSpec+setSize (mp, p) sz = (mp, const (p sz))++-- | Sets a flag on the partition.+setFlag :: PartSpec -> PartFlag -> PartSpec+setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }++-- | Makes a MSDOS partition be Extended, rather than Primary.+extended :: PartSpec -> PartSpec+extended s = adjustp s $ \p -> p { partType = Extended }++adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec+adjustp (mp, p) f = (mp, \sz -> f (p sz))++-- | The constructor for each Partition is passed the size of the files+-- from the chroot that will be put in that partition.+fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTable)+fitChrootSize tt l basesizes = (mounts, parttable)+  where+	(mounts, sizers) = unzip l+	parttable = PartTable tt (map (uncurry id) (zip sizers basesizes))++-- | A pair of properties. The first property is satisfied within the+-- chroot, and is typically used to download the boot loader.+-- The second property is satisfied chrooted into the resulting+-- disk image, and will typically take care of installing the boot loader+-- to the disk image.+type Finalization = (Property NoInfo, Property NoInfo)++-- | Makes grub be the boot loader of the disk image.+grubBooted :: Grub.BIOS -> Finalization+grubBooted bios = (Grub.installed bios, undefined)++noFinalization :: Finalization+noFinalization = (doNothing, doNothing)

@@ -3,7 +3,8 @@ 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.@@ -27,6 +28,12 @@ umountLazy mnt =   	unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ 		errorMessage $ "failed unmounting " ++ mnt++-- | Unmounts anything mounted inside the specified directory.+unmountBelow :: FilePath -> IO ()+unmountBelow d = do+	submnts <- mountPointsBelow d+	forM_ submnts umountLazy  -- | Mounts a device. mount :: FsType -> Source -> FilePath -> IO Bool

@@ -0,0 +1,203 @@+{-# LANGUAGE FlexibleContexts #-}++module Propellor.Property.Parted (+	TableType(..),+	PartTable(..),+	partTableSize,+	Partition(..),+	mkPartition,+	Partition.Fs(..),+	PartSize(..),+	ByteSize,+	toPartSize,+	fromPartSize,+	reducePartSize,+	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)++-- | Gets the total size of the disk specified by the partition table.+partTableSize :: PartTable -> ByteSize+partTableSize (PartTable _ ps) = fromPartSize $+	-- add 1 megabyte to hold the partition table itself+	mconcat (MegaBytes 1 : map partSize ps)++-- | A partition on the disk.+data Partition = Partition+	{ partType :: PartType+	, partSize :: PartSize+	, 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 -> PartSize -> 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 PartSize = MegaBytes Integer+	deriving (Show)++instance PartedVal PartSize where+	val (MegaBytes n)+		| n > 0 = show n ++ "MB"+		-- parted can't make partitions smaller than 1MB;+		-- avoid failure in edge cases+		| otherwise = show "1MB"++-- | Rounds up to the nearest MegaByte.+toPartSize :: ByteSize -> PartSize+toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double)++fromPartSize :: PartSize -> ByteSize+fromPartSize (MegaBytes b) = b * 1000000++instance Monoid PartSize where+	mempty = MegaBytes 0+	mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b)++reducePartSize :: PartSize -> PartSize -> PartSize+reducePartSize (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 $ combineProperties desc+		[ parted eep disk partedparams+		, if isdev+			then formatl (map (\n -> disk ++ show n) [1 :: Int ..])+			else Partition.kpartx disk formatl+		]+  where+	desc = disk ++ " partitioned"+	formatl devs = combineProperties desc (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"]

@@ -0,0 +1,60 @@+{-# 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", q $ eff optsdev, "e2fsprogs")+		EXT3 -> ("mkfs.ext3", q $ eff optsdev, "e2fsprogs")+		EXT4 -> ("mkfs.ext4", q $ eff optsdev, "e2fsprogs")+		BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools")+		REISERFS -> ("mkfs.reiserfs", q $ "-ff":optsdev, "reiserfsprogs")+		XFS -> ("mkfs.xfs", "-f":q optsdev, "xfsprogs")+		FAT -> ("mkfs.fat", optsdev, "dosfstools")+		VFAT -> ("mkfs.vfat", optsdev, "dosfstools")+		NTFS -> ("mkfs.ntfs", q $ eff optsdev, "ntfs-3g")+		LinuxSwap -> ("mkswap", optsdev, "util-linux")+	optsdev = opts++[dev]+	-- -F forces creating a filesystem even if the device already has one+	eff l = "-F":l+	-- Be quiet.+	q l = "-q":l++-- | 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]

@@ -20,7 +20,8 @@ 	-- * Journal 	persistentJournal, 	journaldConfigured,-	-- * Containers+	-- * Containers and machined+	machined, 	MachineName, 	Container, 	container,@@ -160,6 +161,18 @@ 	configured "/etc/systemd/journald.conf" option value 		`onChange` restarted journald +-- | Ensures machined and machinectl are installed+machined :: Property NoInfo+machined = go `describe` "machined installed"+  where+	go = withOS ("standard sources.list") $ \o ->+		case o of+			-- Split into separate debian package since systemd 225.+			(Just (System (Debian suite) _))+				| not (isStable suite) -> ensureProperty $+					Apt.installed ["systemd-container"]+			_ -> noChange+ -- | Defines a container with a given machine name. -- -- Properties can be added to configure the Container.@@ -250,7 +263,7 @@ 			`requires` daemonReloaded 			`requires` writeservicefile -	setup = started service `requires` setupservicefile+	setup = started service `requires` setupservicefile `requires` machined  	teardown = check (doesFileExist servicefile) $ 		disabled service `requires` stopped service

@@ -55,12 +55,15 @@ shebang = "#!/bin/sh"  checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath-checkAlreadyShimmed f nope = withFile f ReadMode $ \h -> do-	fileEncoding h-	s <- hGetLine h-	if s == shebang-		then return f-		else nope+checkAlreadyShimmed f nope = ifM (doesFileExist f)+	( withFile f ReadMode $ \h -> do+		fileEncoding h+		s <- hGetLine h+		if s == shebang+			then return f+			else nope+	, nope+	)  -- Called when the shimmed propellor is running, so that commands it runs -- don't see it.