Merge branch 'joeyconfig'

9 files changed, 238 insertions, 188 deletions

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 2b5391fa..ecac1115 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -34,25 +34,26 @@ import System.Posix.Directory
 -- | Specification of a chroot. Normally you'll use `debootstrapped` or
 -- `bootstrapped` to construct a Chroot value.
 data Chroot where
-	Chroot :: ChrootBootstrapper b => FilePath -> System -> b -> Host -> Chroot
+	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
 
-chrootSystem :: Chroot -> System
-chrootSystem (Chroot _ system _ _) = system
+chrootSystem :: Chroot -> Maybe System
+chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
 
 instance Show Chroot where
-	show (Chroot loc system _ _) = "Chroot " ++ loc ++ " " ++ show system
+	show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
 
 instance PropAccum Chroot where
-	(Chroot l s c h) `addProp` p = Chroot l s c (h & p)
-	(Chroot l s c h) `addPropFront` p = Chroot l s c (h `addPropFront` p)
-	getProperties (Chroot _ _ _ h) = hostProperties h
+	(Chroot l c h) `addProp` p = Chroot l c (h & p)
+	(Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p)
+	getProperties (Chroot _ _ h) = hostProperties h
 
 -- | Class of things that can do initial bootstrapping of an operating
 -- System in a chroot.
 class ChrootBootstrapper b where
 	-- | Do initial bootstrapping of an operating system in a chroot.
-	-- If the operating System is not supported, return Nothing.
-	buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo)
+	-- If the operating System is not supported, return 
+	-- Left error message.
+	buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
 
 -- | Use this to bootstrap a chroot by extracting a tarball.
 --
@@ -63,7 +64,7 @@ class ChrootBootstrapper b where
 data ChrootTarball = ChrootTarball FilePath
 
 instance ChrootBootstrapper ChrootTarball where
-	buildchroot (ChrootTarball tb) _ loc = Just $ extractTarball loc tb
+	buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
 
 extractTarball :: FilePath -> FilePath -> Property HasInfo
 extractTarball target src = toProp .
@@ -83,27 +84,28 @@ data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
 
 instance ChrootBootstrapper Debootstrapped where
 	buildchroot (Debootstrapped cf) system loc = case system of
-		(System (Debian _) _) -> Just debootstrap
-		(System (Ubuntu _) _) -> Just debootstrap
+		(Just s@(System (Debian _) _)) -> Right $ debootstrap s
+		(Just s@(System (Ubuntu _) _)) -> Right $ debootstrap s
+		Nothing -> Left "Cannot debootstrap; `os` property not specified"
 	  where
-		debootstrap = Debootstrap.built loc system cf
+		debootstrap s = Debootstrap.built loc s cf
 
 -- | Defines a Chroot at the given location, built with debootstrap.
 --
--- Properties can be added to configure the Chroot.
+-- Properties can be added to configure the Chroot. At a minimum,
+-- add the `os` property to specify the operating system to bootstrap.
 --
--- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev"
+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
+-- >	& os (System (Debian Unstable) "amd64")
 -- > 	& Apt.installed ["ghc", "haskell-platform"]
 -- > 	& ...
-debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot
-debootstrapped system conf = bootstrapped system (Debootstrapped conf)
+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+debootstrapped conf = bootstrapped (Debootstrapped conf)
 
 -- | Defines a Chroot at the given location, bootstrapped with the
 -- specified ChrootBootstrapper.
-bootstrapped :: ChrootBootstrapper b => System -> b -> FilePath -> Chroot
-bootstrapped system bootstrapper location =
-	Chroot location system bootstrapper h
-		& os system
+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot
+bootstrapped bootstrapper location = Chroot location bootstrapper h
   where
 	h = Host location [] mempty
 
@@ -117,7 +119,7 @@ provisioned :: Chroot -> RevertableProperty
 provisioned c = provisioned' (propagateChrootInfo c) c False
 
 provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
-provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly =
+provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
 	(propigator $ propertyList (chrootDesc c "exists") [setup])
 		<!>
 	(propertyList (chrootDesc c "removed") [teardown])
@@ -125,18 +127,18 @@ provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly =
 	setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
 		`requires` toProp built
 	
-	built = case buildchroot bootstrapper system loc of
-		Just p -> p
-		Nothing -> cantbuild
+	built = case buildchroot bootstrapper (chrootSystem c) loc of
+		Right p -> p
+		Left e -> cantbuild e
 
-	cantbuild = infoProperty (chrootDesc c "built") (error $ "cannot bootstrap " ++ show system ++ " using supplied ChrootBootstrapper") mempty []
+	cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []
 
 	teardown = check (not <$> unpopulated loc) $
 		property ("removed " ++ loc) $
 			makeChange (removeChroot loc)
 
 propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
-propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c p'
+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
   where
 	p' = infoProperty
 		(propertyDesc p)
@@ -145,12 +147,12 @@ propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c
 		(propertyChildren p)
 
 chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ _ h) = mempty `addInfo` 
+chrootInfo (Chroot loc _ h) = mempty `addInfo` 
 	mempty { _chroots = M.singleton loc h }
 
 -- | Propellor is run inside the chroot to provision it.
 propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
-propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
+propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
 	let d = localdir </> shimdir c
 	let me = localdir </> "propellor"
 	shim <- liftIO $ ifM (doesDirectoryExist d)
@@ -189,7 +191,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
 		return r
 
 toChain :: HostName -> Chroot -> Bool -> IO CmdLine
-toChain parenthost (Chroot loc _ _ _) systemdonly = do
+toChain parenthost (Chroot loc _ _) systemdonly = do
 	onconsole <- isConsole <$> mkMessageHandle
 	return $ ChrootChain parenthost loc systemdonly onconsole
 
@@ -214,14 +216,14 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 chain _ _ = errorMessage "bad chain command"
 
 inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
-inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
+inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
 	mountproc
 	return (proc "chroot" (loc:cmd), cleanup)
   where
 	-- /proc needs to be mounted in the chroot for the linker to use
 	-- /proc/self/exe which is necessary for some commands to work
 	mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
-		void $ mount "proc" "proc" procloc
+		void $ mount "proc" "proc" procloc mempty
 	
 	procloc = loc </> "proc"
 
@@ -234,10 +236,10 @@ provisioningLock :: FilePath -> FilePath
 provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"
 
 shimdir :: Chroot -> FilePath
-shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"
+shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim"
 
 mungeloc :: FilePath -> String
 mungeloc = replace "/" "_"
 
 chrootDesc :: Chroot -> String -> String
-chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc
+chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 97880cf4..90d0bcc6 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -5,28 +5,14 @@
 -- TODO avoid starting services while populating chroot and running final
 
 module Propellor.Property.DiskImage (
+	-- * Partition specification
+	module Propellor.Property.DiskImage.PartSpec,
 	-- * 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,
@@ -35,6 +21,7 @@ module Propellor.Property.DiskImage (
 ) where
 
 import Propellor.Base
+import Propellor.Property.DiskImage.PartSpec
 import Propellor.Property.Chroot (Chroot)
 import Propellor.Property.Chroot.Util (removeChroot)
 import qualified Propellor.Property.Chroot as Chroot
@@ -75,6 +62,7 @@ type DiskImage = FilePath
 -- >			`setFlag` BootFlag
 -- >		, partition EXT4 `mountedAt` "/"
 -- >			`addFreeSpace` MegaBytes 100
+-- >			`mountOpt` errorReadonly
 -- >		, swapPartition (MegaBytes 256)
 -- >		]
 --
@@ -123,28 +111,28 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 			<$> liftIO (dirSizes chrootdir)
 		let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
 		-- tie the knot!
-		let (mnts, parttable) = fitChrootSize tabletype partspec $
+		let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
 			map (calcsz mnts) mnts
 		ensureProperty $
 			imageExists img (partTableSize parttable)
 				`before`
 			partitioned YesReallyDeleteDiskContents img parttable
 				`before`
-			kpartx img (mkimg' mnts parttable)
-	mkimg' mnts parttable devs =
-		partitionsPopulated chrootdir mnts devs
+			kpartx img (mkimg' mnts mntopts parttable)
+	mkimg' mnts mntopts parttable devs =
+		partitionsPopulated chrootdir mnts mntopts devs
 			`before`
-		imageFinalized final mnts devs parttable
+		imageFinalized final mnts mntopts devs parttable
 	rmimg = File.notPresent img
 
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [LoopDev] -> Property NoInfo
-partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo
+partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
   where
 	desc = "partitions populated from " ++ chrootdir
 
-	go Nothing _ = noChange
-	go (Just mnt) loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
-		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir)
+	go Nothing _ _ = noChange
+	go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
 		(const $ liftIO $ umountLazy tmpdir)
 		$ \ismounted -> if ismounted
 			then ensureProperty $
@@ -160,26 +148,16 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m
 			[ Include (Pattern m)
 			, Exclude (filesUnder m)
 			-- Preserve any lost+found directory that mkfs made
-			, Exclude (Pattern "lost+found")
+			, Protect (Pattern "lost+found")
 			]) childmnts
 
--- | 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
+-- 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] -> ([Maybe MountPoint], [MountOpts], PartTable)
+fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
+  where
+	(mounts, mountopts, sizers) = unzip3 l
+	parttable = PartTable tt (zipWith id sizers basesizes)
 
 -- | Generates a map of the sizes of the contents of 
 -- every directory in a filesystem tree. 
@@ -210,84 +188,23 @@ getMountSz szm l (Just mntpt) =
   where
 	childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
 
-isChild :: FilePath -> Maybe MountPoint -> Bool
-isChild mntpt (Just d)
-	| d `equalFilePath` mntpt = False
-	| otherwise = mntpt `dirContains` d
-isChild _ Nothing = False
-
--- | 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
-
-defSz :: PartSize
-defSz = MegaBytes 128
-
--- Add 2% for filesystem overhead. Rationalle for picking 2%:
--- A filesystem with 1% overhead might just sneak by as acceptable.
--- Double that just in case. Add an additional 3 mb to deal with
--- non-scaling overhead of filesystems (eg, superblocks). 
--- Add an additional 200 mb for temp files, journals, etc.
-fudge :: PartSize -> PartSize
-fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
-
--- | Specifies a mount point and a constructor for a Partition.
+-- | Ensures that a disk image file of the specified size exists.
 -- 
--- 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. Plus a fudge factor, since filesystems have some space
--- overhead.
---
--- (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 = (Maybe 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.
+-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
 --
--- 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, f . p)
-
--- | 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] -> ([Maybe MountPoint], PartTable)
-fitChrootSize tt l basesizes = (mounts, parttable)
-  where
-	(mounts, sizers) = unzip l
-	parttable = PartTable tt (zipWith id sizers basesizes)
+-- 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
 
 -- | A pair of properties. The first property is satisfied within the
 -- chroot, and is typically used to download the boot loader.
@@ -301,8 +218,8 @@ fitChrootSize tt l basesizes = (mounts, parttable)
 -- in the partition tree.
 type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
 
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [LoopDev] -> PartTable -> Property NoInfo
-imageFinalized (_, final) mnts devs (PartTable _ parts) = 
+imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo
+imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = 
 	property "disk image finalized" $ 
 		withTmpDir "mnt" $ \top -> 
 			go top `finally` liftIO (unmountall top)
@@ -314,19 +231,19 @@ imageFinalized (_, final) mnts devs (PartTable _ parts) =
 	
 	-- Ordered lexographically by mount point, so / comes before /usr
 	-- comes before /usr/local
-	orderedmntsdevs :: [(Maybe MountPoint, LoopDev)]
-	orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs
+	orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
+	orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs)
 	
 	swaps = map (SwapPartition . partitionLoopDev . snd) $
 		filter ((== LinuxSwap) . partFs . fst) $
 			zip parts devs
 
-	mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of
+	mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of
 		Nothing -> noop
 		Just p -> do
 			let mnt = top ++ p
 			createDirectoryIfMissing True mnt
-			unlessM (mount "auto" (partitionLoopDev loopdev) mnt) $
+			unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $
 				error $ "failed mounting " ++ mnt
 
 	unmountall top = do
@@ -353,8 +270,8 @@ grubBooted bios = (Grub.installed' bios, boots)
 	boots mnt loopdevs = combineProperties "disk image boots using grub"
 		-- bind mount host /dev so grub can access the loop devices
 		[ bindMount "/dev" (inmnt "/dev")
-		, mounted "proc" "proc" (inmnt "/proc")
-		, mounted "sysfs" "sys" (inmnt "/sys")
+		, mounted "proc" "proc" (inmnt "/proc") mempty
+		, mounted "sysfs" "sys" (inmnt "/sys") mempty
 		-- update the initramfs so it gets the uuid of the root partition
 		, inchroot "update-initramfs" ["-u"]
 		-- work around for http://bugs.debian.org/802717
@@ -382,3 +299,16 @@ grubBooted bios = (Grub.installed' bios, boots)
 		wholediskloopdev = case loopdevs of
 			(l:_) -> wholeDiskLoopDev l
 			[] -> error "No loop devs provided!"
+
+isChild :: FilePath -> Maybe MountPoint -> Bool
+isChild mntpt (Just d)
+	| d `equalFilePath` mntpt = False
+	| otherwise = mntpt `dirContains` d
+isChild _ Nothing = False
+
+-- | 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
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
new file mode 100644
index 00000000..4b05df03
--- /dev/null
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -0,0 +1,81 @@
+-- | Disk image partition specification and combinators.
+
+module Propellor.Property.DiskImage.PartSpec (
+	module Propellor.Property.DiskImage.PartSpec,
+	Partition,
+	PartSize(..),
+	PartFlag(..),
+	TableType(..),
+	Fs(..),
+	MountPoint,
+) where
+
+import Propellor.Base
+import Propellor.Property.Parted
+import Propellor.Property.Mount
+
+-- | Specifies a mount point, mount options, 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. Plus a fudge factor, since filesystems have some space
+-- overhead.
+type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition)
+
+-- | 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.
+defSz :: PartSize
+defSz = MegaBytes 128
+
+-- | Add 2% for filesystem overhead. Rationalle for picking 2%:
+-- A filesystem with 1% overhead might just sneak by as acceptable.
+-- Double that just in case. Add an additional 3 mb to deal with
+-- non-scaling overhead of filesystems (eg, superblocks). 
+-- Add an additional 200 mb for temp files, journals, etc.
+fudge :: PartSize -> PartSize
+fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
+
+-- | Specifies a swap partition of a given size.
+swapPartition :: PartSize -> PartSpec
+swapPartition sz = (Nothing, mempty, 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, mempty, mkPartition fs)
+
+-- | Specifies where to mount a partition.
+mountedAt :: PartSpec -> FilePath -> PartSpec
+mountedAt (_, o, p) mp = (Just mp, o, p)
+
+-- | Specifies a mount option, such as "noexec"
+mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec
+mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p)
+
+-- | Mount option to make a partition be remounted readonly when there's an
+-- error accessing it.
+errorReadonly :: MountOpts
+errorReadonly = toMountOpts "errors=remount-ro"
+
+-- | Adds additional free space to the partition.
+addFreeSpace :: PartSpec -> PartSize -> PartSpec
+addFreeSpace (mp, o, p) freesz = (mp, o, \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, o, p) sz = (mp, o, 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, o, p) f = (mp, o, f . p)
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 7e421cb7..3476bad0 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -70,6 +70,13 @@ f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
 lacksLines :: FilePath -> [Line] -> Property NoInfo
 f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f
 
+-- | Replaces the content of a file with the transformed content of another file
+basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property NoInfo
+f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f')
+  where
+	desc = "replace " ++ f
+	go tmpl = ensureProperty $ fileProperty desc (\_ -> a $ lines $ tmpl) f
+
 -- | Removes a file. Does not remove symlinks or non-plain-files.
 notPresent :: FilePath -> Property NoInfo
 notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ 
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index a08f9e3b..3f13388b 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}
+
 module Propellor.Property.Mount where
 
 import Propellor.Base
@@ -8,16 +10,36 @@ import Data.Char
 import Data.List
 import Utility.Table
 
-type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect)
+-- | type of filesystem to mount ("auto" to autodetect)
+type FsType = String
 
+-- | A device or other thing to be mounted.
 type Source = String
 
+-- | A mount point for a filesystem.
 type MountPoint = FilePath
 
+-- | Filesystem mount options. Eg, "errors=remount-ro"
+newtype MountOpts = MountOpts [String]
+	deriving Monoid
+
+class ToMountOpts a where
+	toMountOpts :: a -> MountOpts
+	
+instance ToMountOpts MountOpts where
+	toMountOpts = id
+
+instance ToMountOpts String where
+	toMountOpts s = MountOpts [s]
+
+formatMountOpts :: MountOpts -> String
+formatMountOpts (MountOpts []) = "defaults"
+formatMountOpts (MountOpts l) = intercalate "," l
+
 -- | Mounts a device.
-mounted :: FsType -> Source -> MountPoint -> Property NoInfo
-mounted fs src mnt = property (mnt ++ " mounted") $ 
-	toResult <$> liftIO (mount fs src mnt)
+mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo
+mounted fs src mnt opts = property (mnt ++ " mounted") $ 
+	toResult <$> liftIO (mount fs src mnt opts)
 
 -- | Bind mounts the first directory so its contents also appear
 -- in the second directory.
@@ -25,8 +47,13 @@ bindMount :: FilePath -> FilePath -> Property NoInfo
 bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
 	`describe` ("bind mounted " ++ src ++ " to " ++ dest)
 
-mount :: FsType -> Source -> MountPoint -> IO Bool
-mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]
+mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
+mount fs src mnt opts = boolSystem "mount" $
+	[ Param "-t", Param fs
+	, Param "-o", Param (formatMountOpts opts)
+	, Param src
+	, Param mnt
+	]
 
 newtype SwapPartition = SwapPartition FilePath
 
@@ -64,7 +91,7 @@ genFstab mnts swaps mnttransform = do
 				]
 		, pure (mnttransform mnt)
 		, fromMaybe "auto" <$> getFsType mnt
-		, fromMaybe "defaults" <$> getFsOptions mnt
+		, formatMountOpts <$> getFsMountOpts mnt
 		, pure "0"
 		, pure (if mnt == "/" then "1" else "2")
 		]
@@ -75,7 +102,7 @@ genFstab mnts swaps mnttransform = do
 			]
 		, pure "none"
 		, pure "swap"
-		, pure "defaults"
+		, pure (formatMountOpts mempty)
 		, pure "0"
 		, pure "0"
 		]
@@ -115,8 +142,9 @@ getFsType :: MountPoint -> IO (Maybe FsType)
 getFsType = findmntField "fstype"
 
 -- | Mount options for the filesystem mounted at a given location.
-getFsOptions :: MountPoint -> IO (Maybe String)
-getFsOptions = findmntField "fs-options"
+getFsMountOpts :: MountPoint -> IO MountOpts
+getFsMountOpts p = maybe mempty toMountOpts
+	<$> findmntField "fs-options" p
 
 type UUID = String
 
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index e176e33d..1f22888c 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -123,16 +123,16 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 
 		-- Remount /dev, so that block devices etc are
 		-- available for other properties to use.
-		unlessM (mount devfstype devfstype "/dev") $ do
+		unlessM (mount devfstype devfstype "/dev" mempty) $ do
 			warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic"
 			void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"]
 
 		-- Mount /sys too, needed by eg, grub-mkconfig.
-		unlessM (mount "sysfs" "sysfs" "/sys") $
+		unlessM (mount "sysfs" "sysfs" "/sys" mempty) $
 			warningMessage "failed mounting /sys"
 
 		-- And /dev/pts, used by apt.
-		unlessM (mount "devpts" "devpts" "/dev/pts") $
+		unlessM (mount "devpts" "devpts" "/dev/pts" mempty) $
 			warningMessage "failed mounting /dev/pts"
 
 		return MadeChange
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index 894b8cc7..cae3c877 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -22,10 +22,12 @@ syncDir = syncDirFiltered []
 data Filter 
 	= Include Pattern
 	| Exclude Pattern
+	| Protect Pattern
 
 instance RsyncParam Filter where
 	toRsync (Include (Pattern p)) = "--include=" ++ p
 	toRsync (Exclude (Pattern p)) = "--exclude=" ++ p
+	toRsync (Protect (Pattern p)) = "--filter=P " ++ p
 
 -- | A pattern to match against files that rsync is going to transfer.
 --
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index a10e5877..3f7cbad1 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -99,13 +99,12 @@ cabalDeps = flagFile go cabalupdated
 
 autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container
 autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout =
-	Systemd.container name bootstrap
+	Systemd.container name osver (Chroot.debootstrapped mempty)
 		& mkprop osver flavor
 		& buildDepsApt
 		& autobuilder arch crontime timeout
   where
 	name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
-	bootstrap = Chroot.debootstrapped osver mempty
 
 type Flavor = Maybe String
 
@@ -144,8 +143,7 @@ androidContainer
 	-> Property i
 	-> FilePath
 	-> Systemd.Container
-androidContainer name setupgitannexdir gitannexdir = Systemd.container name bootstrap
-	& os osver
+androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap
 	& Apt.stdSourcesList
 	& User.accountFor (User builduser)
 	& File.dirExists gitbuilderdir
@@ -161,4 +159,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name boot
 		[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
 		]
 	osver = System (Debian (Stable "jessie")) "i386"
-	bootstrap = Chroot.debootstrapped osver mempty
+	bootstrap = Chroot.debootstrapped mempty
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index d5373e15..700bc350 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -174,21 +174,22 @@ machined = go `describe` "machined installed"
 					Apt.installed ["systemd-container"]
 			_ -> noChange
 
--- | Defines a container with a given machine name.
+-- | Defines a container with a given machine name, and operating system,
+-- and how to create its chroot if not already present.
 --
 -- Properties can be added to configure the Container.
 --
--- > container "webserver" (Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty)
+-- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty)
 -- >    & Apt.installedRunning "apache2"
 -- >    & ...
-container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
-container name mkchroot = Container name c h
+container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container
+container name system mkchroot = Container name c h
 	& os system
 	& resolvConfed
 	& linkJournal
   where
 	c = mkchroot (containerDir name)
-	system = Chroot.chrootSystem c
+		& os system
 	h = Host name [] mempty
 
 -- | Runs a container using systemd-nspawn.
@@ -206,7 +207,7 @@ container name mkchroot = Container name c h
 -- Reverting this property stops the container, removes the systemd unit,
 -- and deletes the chroot and all its contents.
 nspawned :: Container -> RevertableProperty
-nspawned c@(Container name (Chroot.Chroot loc system builder _) h) =
+nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
 	p `describe` ("nspawned " ++ name)
   where
 	p = enterScript c
@@ -226,7 +227,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builder _) h) =
 			<!>
 		doNothing
 
-	chroot = Chroot.Chroot loc system builder h
+	chroot = Chroot.Chroot loc builder h
 
 -- | Sets up the service file for the container, and then starts
 -- it running.
@@ -382,7 +383,8 @@ instance Publishable (Proto, Bound Port) where
 -- > 		`requires` Systemd.running Systemd.networkd
 -- >
 -- > webserver :: Systemd.container
--- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty)
+-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty)
+-- >	& os (System (Debian Testing) "amd64")
 -- >	& Systemd.privateNetwork
 -- >	& Systemd.running Systemd.networkd
 -- >	& Systemd.publish (Port 80 ->- Port 8080)