propellor 2.11.0 → 2.12.0

raw patch · 24 files changed

+704/−259 lines, 24 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +21/−0
• README.md +3/−2
• config-joey.hs +16/−12
• debian/changelog +21/−0
• doc/README.mdwn +3/−2
• propellor.cabal +2/−1
• src/Propellor/Property.hs +6/−5
• src/Propellor/Property/Chroot.hs +83/−39
• src/Propellor/Property/DiskImage.hs +155/−139
• src/Propellor/Property/DiskImage/PartSpec.hs +81/−0
• src/Propellor/Property/File.hs +7/−0
• src/Propellor/Property/Grub.hs +12/−7
• src/Propellor/Property/Hostname.hs +45/−8
• src/Propellor/Property/Mount.hs +167/−12
• src/Propellor/Property/OS.hs +3/−3
• src/Propellor/Property/Parted.hs +1/−1
• src/Propellor/Property/Partition.hs +36/−8
• src/Propellor/Property/Rsync.hs +2/−0
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +3/−5
• src/Propellor/Property/SiteSpecific/JoeySites.hs +2/−0
• src/Propellor/Property/Ssh.hs +1/−0
• src/Propellor/Property/Systemd.hs +11/−9
• src/Propellor/Property/User.hs +13/−6
• src/Propellor/Types.hs +10/−0

@@ -1,3 +1,24 @@+propellor (2.12.0) unstable; urgency=medium++  * The DiskImage module can now make bootable images using grub.+  * Add a ChrootTarball chroot type, for using pre-built tarballs+    as chroots. Thanks, Ben Boeckel.+  * HostName: Improve domain extraction code.+  * Added Mount.fstabbed property to generate /etc/fstab to replicate+    current mounts.+  * HostName: Improve domain extraction code.+  * Add File.basedOn. Thanks, Per Olofsson.+  * Changed how the operating system is provided to Chroot (API change).+    Where before debootstrapped and bootstrapped took a System parameter,+    the os property should now be added to the Chroot.+  * Follow-on change to Systemd.container, which now takes a System parameter.+  * Generalized Property.check so it can be used with Propellor actions as+    well as IO actions.+  * Hostname.sane and Hostname.setTo can now safely be used as a property+    of a chroot, and won't affect the hostname of the host system.++ -- Joey Hess <id@joeyh.name>  Fri, 23 Oct 2015 17:38:32 -0400+ propellor (2.11.0) unstable; urgency=medium    * Rewrote Propellor.Property.ControlHeir one more time, renaming it to

@@ -53,6 +53,7 @@    So, edit `~/.propellor/config.hs` to configure the host, add some    properties to it, and re-run step 6.      Repeat until happy and move on to the next host. :)-8. Optionally, set up a [centralized git repository](https://propellor.branchable.com/centralized_git_repository/)-   so that multiple hosts can be updated with a simple `git commit -S; git push`+8. Once you have a lot of hosts, and running `propellor --spin HOST` for+   each host becomes tiresome, you can+   [automate that](http://propellor.branchable.com/automated_spins/). 9. Write some neat new properties and send patches!

@@ -81,14 +81,19 @@ 	& 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)+	& imageBuilt "/tmp/img" c MSDOS (grubBooted PC)+		[ partition EXT2 `mountedAt` "/boot"+			`setFlag` BootFlag+		, partition EXT4 `mountedAt` "/"+			`mountOpt` errorReadonly+		, swapPartition (MegaBytes 256)+		]   where-	c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d+	c d = Chroot.debootstrapped mempty d+		& os (System (Debian Unstable) "amd64")+		& Hostname.setTo "demo" 		& Apt.installed ["linux-image-amd64"]+		& User "root" `User.hasInsecurePassword` "root"  gnu :: Host gnu = host "gnu.kitenet.net"@@ -492,14 +497,13 @@  -- This is my standard container setup, Featuring automatic upgrades. standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container-standardContainer name suite arch = Systemd.container name chroot-	& os system-	& Apt.stdSourcesList `onChange` Apt.upgrade-	& Apt.unattendedUpgrades-	& Apt.cacheCleaned+standardContainer name suite arch =+	Systemd.container name system (Chroot.debootstrapped mempty)+		& Apt.stdSourcesList `onChange` Apt.upgrade+		& Apt.unattendedUpgrades+		& Apt.cacheCleaned   where 	system = System (Debian suite) arch-	chroot = Chroot.debootstrapped system mempty  standardStableContainer :: Systemd.MachineName -> Systemd.Container standardStableContainer name = standardContainer name (Stable "jessie") "amd64"

@@ -1,3 +1,24 @@+propellor (2.12.0) unstable; urgency=medium++  * The DiskImage module can now make bootable images using grub.+  * Add a ChrootTarball chroot type, for using pre-built tarballs+    as chroots. Thanks, Ben Boeckel.+  * HostName: Improve domain extraction code.+  * Added Mount.fstabbed property to generate /etc/fstab to replicate+    current mounts.+  * HostName: Improve domain extraction code.+  * Add File.basedOn. Thanks, Per Olofsson.+  * Changed how the operating system is provided to Chroot (API change).+    Where before debootstrapped and bootstrapped took a System parameter,+    the os property should now be added to the Chroot.+  * Follow-on change to Systemd.container, which now takes a System parameter.+  * Generalized Property.check so it can be used with Propellor actions as+    well as IO actions.+  * Hostname.sane and Hostname.setTo can now safely be used as a property+    of a chroot, and won't affect the hostname of the host system.++ -- Joey Hess <id@joeyh.name>  Fri, 23 Oct 2015 17:38:32 -0400+ propellor (2.11.0) unstable; urgency=medium    * Rewrote Propellor.Property.ControlHeir one more time, renaming it to

@@ -53,6 +53,7 @@    So, edit `~/.propellor/config.hs` to configure the host, add some    properties to it, and re-run step 6.      Repeat until happy and move on to the next host. :)-8. Optionally, set up a [centralized git repository](https://propellor.branchable.com/centralized_git_repository/)-   so that multiple hosts can be updated with a simple `git commit -S; git push`+8. Once you have a lot of hosts, and running `propellor --spin HOST` for+   each host becomes tiresome, you can+   [automate that](http://propellor.branchable.com/automated_spins/). 9. Write some neat new properties and send patches!

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.11.0+Version: 2.12.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -84,6 +84,7 @@     Propellor.Property.DebianMirror     Propellor.Property.Debootstrap     Propellor.Property.DiskImage+    Propellor.Property.DiskImage.PartSpec     Propellor.Property.Dns     Propellor.Property.DnsSec     Propellor.Property.Docker

@@ -142,11 +142,12 @@ ensureProperty = catchPropellor . propertySatisfy  -- | Makes a Property only need to do anything when a test succeeds.-check :: IO Bool -> Property i -> Property i-check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c)-	( satisfy-	, return NoChange-	)+check :: (LiftPropellor m) => m Bool -> Property i -> Property i+check c p = adjustPropertySatisfy p $ \satisfy -> +	ifM (liftPropellor c)+		( satisfy+		, return NoChange+		)  -- | Tries the first property, but if it fails to work, instead uses -- the second.

@@ -1,12 +1,14 @@-{-# LANGUAGE FlexibleContexts, GADTs #-}+{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-}  module Propellor.Property.Chroot (-	Chroot(..),-	ChrootBootstrapper(..),-	Debootstrapped(..), 	debootstrapped, 	bootstrapped, 	provisioned,+	Chroot(..),+	ChrootBootstrapper(..),+	Debootstrapped(..),+	ChrootTarball(..),+	inChroot, 	-- * Internal use 	provisioned', 	propagateChrootInfo,@@ -22,6 +24,7 @@ import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd+import qualified Propellor.Property.File as File import qualified Propellor.Shim as Shim import Propellor.Property.Mount @@ -32,52 +35,78 @@ -- | 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 to bootstrap a chroot with debootstrap.+-- | Use this to bootstrap a chroot by extracting a tarball.+--+-- The tarball is expected to contain a root directory (no top-level+-- directory, also known as a "tarbomb").+-- It may be optionally compressed with any format `tar` knows how to+-- detect automatically.+data ChrootTarball = ChrootTarball FilePath++instance ChrootBootstrapper ChrootTarball where+	buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb++extractTarball :: FilePath -> FilePath -> Property HasInfo+extractTarball target src = toProp .+	check (unpopulated target) $+		cmdProperty "tar" params+			`requires` File.dirExists target+  where+	params =+		[ "-C"+		, target+		, "-xf"+		, src+		]++-- | Use this to bootstrap a chroot with debootstrap. 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 @@ -91,7 +120,7 @@ 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])@@ -99,18 +128,18 @@ 	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)@@ -119,12 +148,12 @@ 		(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)@@ -163,7 +192,7 @@ 		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 @@ -179,7 +208,7 @@ 		changeWorkingDirectory localdir 		when onconsole forceConsole 		onlyProcess (provisioningLock loc) $ do-			r <- runPropellor h $ ensureProperties $+			r <- runPropellor (setInChroot h) $ ensureProperties $ 				if systemdonly 					then [Systemd.installed] 					else map ignoreInfo $@@ -188,14 +217,14 @@ 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" @@ -208,10 +237,25 @@ 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++-- | Check if propellor is currently running within a chroot.+--+-- This allows properties to check and avoid performing actions that+-- should not be done in a chroot.+inChroot :: Propellor Bool+inChroot = extract . fromMaybe (InChroot False) . fromInfoVal <$> askInfo+  where+	extract (InChroot b) = b++setInChroot :: Host -> Host+setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) }++newtype InChroot = InChroot Bool+	deriving (Typeable, Show)

@@ -2,33 +2,17 @@ -- -- This module is designed to be imported unqualified. ----- TODO run final---  -- 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,@@ -37,6 +21,7 @@ ) 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@@ -49,7 +34,8 @@ import Propellor.Property.Rsync import Utility.Path -import Data.List (isPrefixOf)+import Data.List (isPrefixOf, isInfixOf, sortBy)+import Data.Function (on) import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L import System.Posix.Files@@ -70,25 +56,31 @@ -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d -- > 		& Apt.installed ["linux-image-amd64"] -- >		& ...--- > in imageBuilt "/srv/images/foo.img" chroot MSDOS +-- > in imageBuilt "/srv/images/foo.img" chroot+-- >		MSDOS (grubBooted PC) -- >		[ partition EXT2 `mountedAt` "/boot" -- >			`setFlag` BootFlag -- >		, partition EXT4 `mountedAt` "/" -- >			`addFreeSpace` MegaBytes 100+-- >			`mountOpt` errorReadonly -- >		, swapPartition (MegaBytes 256)--- >		] (grubBooted PC)-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty+-- >		]+--+-- Note that the disk image file is reused if it already exists,+-- to avoid expensive IO to generate a new one. And, it's updated in-place,+-- so its contents are undefined during the build process.+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> 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 :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> 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)+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty+imageBuilt' rebuild img mkchroot tabletype final partspec = +	imageBuiltFrom img chrootdir tabletype final partspec 		`requires` Chroot.provisioned chroot 		`requires` (cleanrebuild <!> doNothing) 		`describe` desc@@ -107,10 +99,8 @@ 		& Apt.cacheCleaned  -- | Builds a disk image from the contents of a chroot.------ The passed property is run inside the mounted disk image.-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty-imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty+imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg   where 	desc = img ++ " built from " ++ chrootdir 	mkimg = property desc $ do@@ -121,25 +111,30 @@ 			<$> liftIO (dirSizes chrootdir) 		let calcsz mnts = maybe defSz fudge . getMountSz szm mnts 		-- tie the knot!-		let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)+		let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $+			map (calcsz mnts) mnts 		ensureProperty $-			imageExists img (partTableSize t)+			imageExists img (partTableSize parttable) 				`before`-			partitioned YesReallyDeleteDiskContents img t+			partitioned YesReallyDeleteDiskContents img parttable 				`before`-			kpartx img (partitionsPopulated chrootdir mnts)+			kpartx img (mkimg' mnts mntopts parttable)+	mkimg' mnts mntopts parttable devs =+		partitionsPopulated chrootdir mnts mntopts devs+			`before`+		imageFinalized final mnts mntopts devs parttable 	rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> 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) dev = withTmpDir "mnt" $ \tmpdir -> bracket-		(liftIO $ mount "auto" dev tmpdir)+	go Nothing _ _ = noChange+	go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket+		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) 		(const $ liftIO $ umountLazy tmpdir)-		$ \mounted -> if mounted+		$ \ismounted -> if ismounted 			then ensureProperty $ 				syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir 			else return FailedChange@@ -152,25 +147,17 @@ 			-- Include the child mount point, but exclude its contents. 			[ Include (Pattern m) 			, Exclude (filesUnder m)+			-- Preserve any lost+found directory that mkfs made+			, 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. @@ -194,105 +181,134 @@ 			else go (M.insertWith (+) dir sz m) dir is 	subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent -getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize+getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize getMountSz _ _ Nothing = Nothing getMountSz szm l (Just mntpt) =  	fmap (`reducePartSize` childsz) (M.lookup mntpt szm)   where 	childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) -isChild :: FilePath -> 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---- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.-type MountPoint = Maybe FilePath--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).-fudge :: PartSize -> PartSize-fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3)---- | 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.+-- If the file doesn't exist, or is too small, creates a new one, full of 0's. ----- (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))+-- 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 --- | Specifies a partition with a given filesystem.+-- | A pair of properties. The first property is satisfied within the+-- chroot, and is typically used to download the boot loader. ----- The partition is not mounted anywhere by default; use the combinators--- below to configure it.-partition :: Fs -> PartSpec-partition fs = (Nothing, mkPartition fs)+-- The second property is run after the disk image is created,+-- with its populated partition tree mounted in the provided+-- location from the provided loop devices. This will typically+-- take care of installing the boot loader to the image.+-- +-- It's ok if the second property leaves additional things mounted+-- in the partition tree.+type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo)) --- | Specifies where to mount a partition.-mountedAt :: PartSpec -> FilePath -> PartSpec-mountedAt (_, p) mp = (Just mp, p)+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)+  where+	go top = do+		liftIO $ mountall top+		liftIO $ writefstab top+		ensureProperty $ final top devs+	+	-- Ordered lexographically by mount point, so / comes before /usr+	-- comes before /usr/local+	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 --- | Adds additional free space to the partition.-addFreeSpace :: PartSpec -> PartSize -> PartSpec-addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz))+	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 mopts) $+				error $ "failed mounting " ++ mnt --- | 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))+	unmountall top = do+		unmountBelow top+		umountLazy top+	+	writefstab top = do+		let fstab = top ++ "/etc/fstab"+		old <- catchDefaultIO [] $ filter (not . unconfigured) . lines+			<$> readFileStrict fstab+		new <- genFstab (map (top ++) (catMaybes mnts))+			swaps (toSysDir top)+		writeFile fstab $ unlines $ new ++ old+	-- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM"+	unconfigured s = "UNCONFIGURED" `isInfixOf` s --- | Sets a flag on the partition.-setFlag :: PartSpec -> PartFlag -> PartSpec-setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }+noFinalization :: Finalization+noFinalization = (doNothing, \_ _ -> doNothing) --- | Makes a MSDOS partition be Extended, rather than Primary.-extended :: PartSpec -> PartSpec-extended s = adjustp s $ \p -> p { partType = Extended }+-- | Makes grub be the boot loader of the disk image.+grubBooted :: Grub.BIOS -> Finalization+grubBooted bios = (Grub.installed' bios, boots)+  where+	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") 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+		 , check haveosprober $ inchroot "chmod" ["-x", osprober]+		, inchroot "update-grub" []+		, check haveosprober $ inchroot "chmod" ["+x", osprober]+		, inchroot "grub-install" [wholediskloopdev]+		-- sync all buffered changes out to the disk image+		-- may not be necessary, but seemed needed sometimes+		-- when using the disk image right away.+		, cmdProperty "sync" []+		]+	  where+	  	-- cannot use </> since the filepath is absolute+		inmnt f = mnt ++ f -adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec-adjustp (mp, p) f = (mp, f . p)+		inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) --- | 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 (zipWith id sizers basesizes)+		haveosprober = doesFileExist (inmnt osprober)+		osprober = "/etc/grub.d/30_os-prober" --- | 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)+		-- It doesn't matter which loopdev we use; all+		-- come from the same disk image, and it's the loop dev+		-- for the whole disk image we seek.+		wholediskloopdev = case loopdevs of+			(l:_) -> wholeDiskLoopDev l+			[] -> error "No loop devs provided!" --- | Makes grub be the boot loader of the disk image.--- TODO not implemented-grubBooted :: Grub.BIOS -> Finalization-grubBooted bios = (Grub.installed bios, undefined)+isChild :: FilePath -> Maybe MountPoint -> Bool+isChild mntpt (Just d)+	| d `equalFilePath` mntpt = False+	| otherwise = mntpt `dirContains` d+isChild _ Nothing = False -noFinalization :: Finalization-noFinalization = (doNothing, doNothing)+-- | 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

@@ -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)

@@ -70,6 +70,13 @@ 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") $ 

@@ -18,14 +18,19 @@ -- | Installs the grub package. This does not make grub be used as the -- bootloader. ----- This includes running update-grub, so that the grub boot menu is--- created. It will be automatically updated when kernel packages are--- installed.+-- This includes running update-grub. installed :: BIOS -> Property NoInfo-installed bios = -	Apt.installed [pkg] `describe` "grub package installed"-		`before`-	cmdProperty "update-grub" []+installed bios = installed' bios `before` mkConfig++-- Run update-grub, to generate the grub boot menu. It will be+-- automatically updated when kernel packages are+--   -- installed.+mkConfig :: Property NoInfo+mkConfig = cmdProperty "update-grub" []++-- | Installs grub; does not run update-grub.+installed' :: BIOS -> Property NoInfo+installed' bios = Apt.installed [pkg] `describe` "grub package installed"   where 	pkg = case bios of 		PC -> "grub-pc"

@@ -2,12 +2,17 @@  import Propellor.Base import qualified Propellor.Property.File as File+import Propellor.Property.Chroot (inChroot)  import Data.List+import Data.List.Utils --- | Ensures that the hostname is set using best practices.+-- | Ensures that the hostname is set using best practices, to whatever+-- name the `Host` has. ----- Configures </etc/hostname> and the current hostname.+-- Configures both </etc/hostname> and the current hostname.+-- (However, when used inside a chroot, avoids setting the current hostname+-- as that would impact the system outside the chroot.) -- -- Configures </etc/mailname> with the domain part of the hostname. --@@ -18,13 +23,23 @@ -- other hostnames there is not best practices and can lead to annoying -- messages from eg, apache. sane :: Property NoInfo-sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)+sane = sane' extractDomain +sane' :: ExtractDomain -> Property NoInfo+sane' extractdomain = property ("sane hostname") $+	ensureProperty . setTo' extractdomain =<< asks hostName++-- Like `sane`, but you can specify the hostname to use, instead+-- of the default hostname of the `Host`. setTo :: HostName -> Property NoInfo-setTo hn = combineProperties desc go+setTo = setTo' extractDomain++setTo' :: ExtractDomain -> HostName -> Property NoInfo+setTo' extractdomain hn = combineProperties desc go   where 	desc = "hostname " ++ hn-	(basehost, domain) = separate (== '.') hn+	basehost = takeWhile (/= '.') hn+	domain = extractdomain hn  	go = catMaybes 		[ Just $ "/etc/hostname" `File.hasContent` [basehost]@@ -32,7 +47,8 @@ 			then Nothing  			else Just $ trivial $ hostsline "127.0.1.1" [hn, basehost] 		, Just $ trivial $ hostsline "127.0.0.1" ["localhost"]-		, Just $ trivial $ cmdProperty "hostname" [basehost]+		, Just $ trivial $ check (not <$> inChroot) $+			cmdProperty "hostname" [basehost] 		, Just $ "/etc/mailname" `File.hasContent` 			[if null domain then hn else domain] 		]@@ -47,11 +63,14 @@ -- | Makes </etc/resolv.conf> contain search and domain lines for  -- the domain that the hostname is in. searchDomain :: Property NoInfo-searchDomain = property desc (ensureProperty . go =<< asks hostName)+searchDomain = searchDomain' extractDomain++searchDomain' :: ExtractDomain -> Property NoInfo+searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)   where 	desc = "resolv.conf search and domain configured" 	go hn =-		let (_basehost, domain) = separate (== '.') hn+		let domain = extractdomain hn 		in  File.fileProperty desc (use domain) "/etc/resolv.conf" 	use domain ls = filter wanted $ nub (ls ++ cfgs) 	  where@@ -61,3 +80,21 @@ 			| "domain " `isPrefixOf` l = False 			| "search " `isPrefixOf` l = False 			| otherwise = True++-- | Function to extract the domain name from a HostName.+type ExtractDomain = HostName -> String++-- | hostname of foo.example.com has a domain of example.com.+-- But, when the hostname is example.com, the domain is+-- example.com too.+--+-- This doesn't work for eg, foo.co.uk, or when foo.sci.uni.edu+-- is in a sci.uni.edu subdomain. If you are in such a network,+-- provide your own ExtractDomain function to the properties above.+extractDomain :: ExtractDomain+extractDomain hn = +	let bits = split "." hn+	in intercalate "." $+		if length bits > 2+			then drop 1 bits+			else bits

@@ -1,29 +1,188 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}+ module Propellor.Property.Mount where  import Propellor.Base+import qualified Propellor.Property.File as File import Utility.Path -type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect)+import Data.Char+import Data.List+import Utility.Table +-- | 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 -> 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.+bindMount :: FilePath -> FilePath -> Property NoInfo+bindMount src dest = cmdProperty "mount" ["--bind", src, dest]+	`describe` ("bind mounted " ++ src ++ " to " ++ dest)++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++-- | Replaces </etc/fstab> with a file that should cause the currently+-- mounted partitions to be re-mounted the same way on boot.+--+-- For each specified MountPoint, the UUID of each partition+-- (or if there is no UUID, its label), its filesystem type,+-- and its mount options are all automatically probed.+--+-- The SwapPartitions are also included in the generated fstab.+fstabbed :: [MountPoint] -> [SwapPartition] -> Property NoInfo+fstabbed mnts swaps = property "fstabbed" $ do+	fstab <- liftIO $ genFstab mnts swaps id+	ensureProperty $ +		"/etc/fstab" `File.hasContent` fstab++genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]+genFstab mnts swaps mnttransform = do+	fstab <- liftIO $ mapM getcfg (sort mnts)+	swapfstab <- liftIO $ mapM getswapcfg swaps+	return $ header ++ formatTable (legend : fstab ++ swapfstab)+  where+	header =+		[ "# /etc/fstab: static file system information. See fstab(5)"+		, "# "+		]+	legend = ["# <file system>", "<mount point>", "<type>", "<options>", "<dump>", "<pass>"]+	getcfg mnt = sequence+		[ fromMaybe (error $ "unable to find mount source for " ++ mnt)+			<$> getM (\a -> a mnt)+				[ uuidprefix getMountUUID+				, sourceprefix getMountLabel+				, getMountSource+				]+		, pure (mnttransform mnt)+		, fromMaybe "auto" <$> getFsType mnt+		, formatMountOpts <$> getFsMountOpts mnt+		, pure "0"+		, pure (if mnt == "/" then "1" else "2")+		]+	getswapcfg (SwapPartition swap) = sequence+		[ fromMaybe swap <$> getM (\a -> a swap)+			[ uuidprefix getSourceUUID+			, sourceprefix getSourceLabel+			]+		, pure "none"+		, pure "swap"+		, pure (formatMountOpts mempty)+		, pure "0"+		, pure "0"+		]+	prefix s getter m = fmap (s ++) <$> getter m+	uuidprefix = prefix "UUID="+	sourceprefix = prefix "LABEL="++-- | Checks if </etc/fstab> is not configured. +-- This is the case if it doesn't exist, or+-- consists entirely of blank lines or comments.+--+-- So, if you want to only replace the fstab once, and then never touch it+-- again, allowing local modifications:+--+-- > check noFstab (fstabbed mnts [])+noFstab :: IO Bool+noFstab = ifM (doesFileExist "/etc/fstab")+	( null . filter iscfg . lines <$> readFile "/etc/fstab"+	, return True+	)+  where+	iscfg l+		| null l = False+		| otherwise = not $ "#" `isPrefixOf` dropWhile isSpace l+	 -- | Lists all mount points of the system.-mountPoints :: IO [FilePath]+mountPoints :: IO [MountPoint] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]  -- | Finds all filesystems mounted inside the specified directory.-mountPointsBelow :: FilePath -> IO [FilePath]+mountPointsBelow :: FilePath -> IO [MountPoint] mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target) 	. filter (dirContains target) 	<$> mountPoints  -- | Filesystem type mounted at a given location.-getFsType :: FilePath -> IO (Maybe FsType)-getFsType mnt = catchDefaultIO Nothing $-	headMaybe . lines-		<$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]+getFsType :: MountPoint -> IO (Maybe FsType)+getFsType = findmntField "fstype" --- | Unmounts a device, lazily so any running processes don't block it.+-- | Mount options for the filesystem mounted at a given location.+getFsMountOpts :: MountPoint -> IO MountOpts+getFsMountOpts p = maybe mempty toMountOpts+	<$> findmntField "fs-options" p++type UUID = String++-- | UUID of filesystem mounted at a given location.+getMountUUID :: MountPoint -> IO (Maybe UUID)+getMountUUID = findmntField "uuid"++-- | UUID of a device+getSourceUUID :: Source -> IO (Maybe UUID)+getSourceUUID = blkidTag "UUID"++type Label = String++-- | Label of filesystem mounted at a given location.+getMountLabel :: MountPoint -> IO (Maybe Label)+getMountLabel = findmntField "label"++-- | Label of a device+getSourceLabel :: Source -> IO (Maybe UUID)+getSourceLabel = blkidTag "LABEL"++-- | Device mounted at a given location.+getMountSource :: MountPoint -> IO (Maybe Source)+getMountSource = findmntField "source"++findmntField :: String -> FilePath -> IO (Maybe String)+findmntField field mnt = catchDefaultIO Nothing $+	headMaybe . filter (not . null) . lines+		<$> readProcess "findmnt" ["-n", mnt, "--output", field]++blkidTag :: String -> Source -> IO (Maybe String)+blkidTag tag dev = catchDefaultIO Nothing $+	headMaybe . filter (not . null) . lines+		<$> readProcess "blkid" [dev, "-s", tag, "-o", "value"]++-- | Unmounts a device or mountpoint,+-- lazily so any running processes don't block it. umountLazy :: FilePath -> IO () umountLazy mnt =   	unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $@@ -34,7 +193,3 @@ unmountBelow d = do 	submnts <- mountPointsBelow d 	forM_ submnts umountLazy---- | Mounts a device.-mount :: FsType -> Source -> FilePath -> IO Bool-mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]

@@ -123,16 +123,16 @@  		-- 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

@@ -160,7 +160,7 @@ 		[ parted eep disk partedparams 		, if isdev 			then formatl (map (\n -> disk ++ show n) [1 :: Int ..])-			else Partition.kpartx disk formatl+			else Partition.kpartx disk (formatl . map Partition.partitionLoopDev) 		]   where 	desc = disk ++ " partitioned"

@@ -4,10 +4,14 @@  import Propellor.Base import qualified Propellor.Property.Apt as Apt+import Utility.Applicative +import System.Posix.Files+import Data.List+ -- | Filesystems etc that can be used for a partition. data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap-	deriving (Show)+	deriving (Show, Eq)  data Eep = YesReallyFormatPartition @@ -41,20 +45,44 @@ 	-- Be quiet. 	q l = "-q":l +data LoopDev = LoopDev+	{ partitionLoopDev :: FilePath -- ^ device for a loop partition+	, wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk+	} deriving (Show)++isLoopDev :: LoopDev -> IO Bool+isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev l)++isLoopDev' :: FilePath -> IO Bool+isLoopDev' f+	| "loop" `isInfixOf` f = catchBoolIO $+		isBlockDevice <$> getFileStatus f+	| otherwise = return False+ -- | Uses the kpartx utility to create device maps for partitions contained--- within a disk image file. The resulting devices are passed to the+-- within a disk image file. The resulting loop 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 :: FilePath -> ([LoopDev] -> 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))+		loopdevs <- liftIO $ kpartxParse+			<$> readProcess "kpartx" ["-avs", diskimage]+		bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs+		unless (null bad) $+			error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad+		r <- ensureProperty (mkprop loopdevs) 		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]++kpartxParse :: String -> [LoopDev]+kpartxParse = mapMaybe (finddev . words) . lines+  where+	finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev +		{ partitionLoopDev = "/dev/mapper/" ++ ld+		, wholeDiskLoopDev = wd+		}+	finddev _ = Nothing

@@ -22,10 +22,12 @@ 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. --

@@ -99,13 +99,12 @@  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 @@ 	-> 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 @@ 		[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" 		] 	osver = System (Debian (Stable "jessie")) "i386"-	bootstrap = Chroot.debootstrapped osver mempty+	bootstrap = Chroot.debootstrapped mempty

@@ -15,6 +15,7 @@ import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix+import qualified Propellor.Property.Systemd as Systemd import Utility.FileMode  import Data.List@@ -346,6 +347,7 @@ 		`onChange` Service.restarted "rsync" 	& "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" 		`onChange` Service.running "rsync"+	& Systemd.enabled "rsync" 	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" 	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-yosemite" 	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/windows"

@@ -4,6 +4,7 @@ 	installed, 	restarted, 	PubKeyText,+	SshKeyType(..), 	-- * Daemon configuration 	sshdConfig, 	ConfigKeyword,

@@ -174,21 +174,22 @@ 					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 @@ -- 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@@ -216,7 +217,7 @@  	-- Chroot provisioning is run in systemd-only mode, 	-- which sets up the chroot and ensures systemd and dbus are-	-- installed, but does not handle the other provisions.+	-- installed, but does not handle the other properties. 	chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True  	-- Use nsenter to enter container and and run propellor to@@ -226,7 +227,7 @@ 			<!> 		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 @@ -- > 		`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)

@@ -58,14 +58,21 @@ setPassword :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result setPassword getpassword = getpassword $ go   where-	go (Password user, password) = set user (privDataVal password) []-	go (CryptPassword user, hash) = set user (privDataVal hash) ["--encrypted"]+	go (Password user, password) = chpasswd (User user) (privDataVal password) []+	go (CryptPassword user, hash) = chpasswd (User user) (privDataVal hash) ["--encrypted"] 	go (f, _) = error $ "Unexpected type of privdata: " ++ show f -	set user v ps = makeChange $ withHandle StdinHandle createProcessSuccess-		(proc "chpasswd" ps) $ \h -> do-			hPutStrLn h $ user ++ ":" ++ v-			hClose h+-- | Makes a user's password be the passed String. Highly insecure:+-- The password is right there in your config file for anyone to see!+hasInsecurePassword :: User -> String -> Property NoInfo+hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $+	chpasswd u p []++chpasswd :: User -> String -> [String] -> Propellor Result+chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess+	(proc "chpasswd" ps) $ \h -> do+		hPutStrLn h $ user ++ ":" ++ v+		hClose h  lockedPassword :: User -> Property NoInfo lockedPassword user@(User u) = check (not <$> isLockedPassword user) $ cmdProperty "passwd"

@@ -29,6 +29,7 @@ 	, CombinedType 	, combineWith 	, Propellor(..)+	, LiftPropellor(..) 	, EndAction(..) 	, module Propellor.Types.OS 	, module Propellor.Types.Dns@@ -71,6 +72,15 @@ 		, MonadThrow 		, MonadMask 		)++class LiftPropellor m where+	liftPropellor :: m a -> Propellor a++instance LiftPropellor Propellor where+	liftPropellor = id++instance LiftPropellor IO where+	liftPropellor = liftIO  instance Monoid (Propellor Result) where 	mempty = return NoChange