propellor 3.4.1 → 4.0.0

raw patch · 34 files changed

+341/−142 lines, 34 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +33/−0
• Makefile +0/−5
• README.md +2/−2
• debian/changelog +33/−0
• debian/control +0/−1
• doc/README.mdwn +2/−2
• joeyconfig.hs +8/−5
• propellor.cabal +1/−1
• src/Propellor/Bootstrap.hs +0/−3
• src/Propellor/Container.hs +18/−3
• src/Propellor/Engine.hs +3/−1
• src/Propellor/EnsureProperty.hs +2/−2
• src/Propellor/PrivData.hs +3/−3
• src/Propellor/Property.hs +18/−18
• src/Propellor/Property/Apache.hs +18/−0
• src/Propellor/Property/Apt.hs +1/−1
• src/Propellor/Property/Chroot.hs +44/−20
• src/Propellor/Property/Concurrent.hs +7/−4
• src/Propellor/Property/Conductor.hs +3/−3
• src/Propellor/Property/DiskImage.hs +51/−24
• src/Propellor/Property/Docker.hs +3/−2
• src/Propellor/Property/Firejail.hs +1/−1
• src/Propellor/Property/FreeBSD/Pkg.hs +3/−2
• src/Propellor/Property/FreeBSD/Poudriere.hs +1/−1
• src/Propellor/Property/List.hs +1/−1
• src/Propellor/Property/SiteSpecific/JoeySites.hs +16/−10
• src/Propellor/Property/Ssh.hs +2/−2
• src/Propellor/Property/Systemd.hs +3/−3
• src/Propellor/Types.hs +44/−5
• src/Propellor/Types/Chroot.hs +1/−1
• src/Propellor/Types/Core.hs +4/−3
• src/Propellor/Types/Dns.hs +3/−3
• src/Propellor/Types/Docker.hs +1/−1
• src/Propellor/Types/Info.hs +11/−9

@@ -1,3 +1,36 @@+propellor (4.0.0) unstable; urgency=medium++  * Added Monoid instances for Property and RevertableProperty.+  * Removed applyToList. Instead, use mconcat. (API change)+    If you had:  applyToList accountFor [User "joey", User "root"]+    use instead: mconcat (map accountFor [User "joey", User "root"])+  * Makefile: Removed "run" target which was default target.+    "make" now only builds propellor, does not run it.+    Note that propellor 1.0.0 and earlier relied on this target for+    the Cron.runPropellor property's cronjob to work, so upgrading+    directly from 1.0.0 to 4.0.0 would break that cron job.+  * Remove make from propellor's dependency list; it's not used by+    propellor any longer.+  * Implemented hostChroot, as originally seen in my slides at+    Linux.Conf.Au 2017 in January. Now that it's not vaporware, it allows+    one Host to build a disk image that has all the properties of another+    Host.+  * DiskImage building properties used to propagate DNS info out from+    the chroot used to build the disk image to the Host. That is no longer+    done, since that chroot only exists as a side effect of the disk image+    creation and servers will not be running in it.+  * The IsInfo types class's propagateInfo function changed to use a+    PropagateInfo data type. (API change)+  * The action used to satisfy a property changed to Maybe (Propellor Result).+    When it is Nothing, propellor knows it can skip displaying the+    description of that property. This is mostly useful in the+    implementation of mempty. (API change)+  * The doNothing property is now simply mempty. The name was retained+    because it can be clearer than mempty in some contexts.+  * Added Apache.confEnabled.++ -- Joey Hess <id@joeyh.name>  Wed, 15 Mar 2017 15:46:42 -0400+ propellor (3.4.1) unstable; urgency=medium    * Fixed https url to propellor git repository.

@@ -1,11 +1,6 @@ CABAL?=cabal DATE := $(shell dpkg-parsechangelog 2>/dev/null | grep Date | cut -d " " -f2-) -# this target is provided (and is first) to keep old versions of the-# propellor cron job working, and will eventually be removed-run: build-	./propellor- build: tags propellor.1 dist/setup-config 	$(CABAL) build 	ln -sf dist/build/propellor-config/propellor-config propellor

@@ -12,8 +12,8 @@ [components](http://propellor.branchable.com/components/) for details. -Properties are defined using Haskell. Edit `~/.propellor/config.hs`-to get started. There is fairly complete +Properties are defined using Haskell in the file `~/.propellor/config.hs`.+There is fairly complete  [API documentation](http://hackage.haskell.org/package/propellor/), which includes many built-in Properties for dealing with [Apt](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apt.html)

@@ -1,3 +1,36 @@+propellor (4.0.0) unstable; urgency=medium++  * Added Monoid instances for Property and RevertableProperty.+  * Removed applyToList. Instead, use mconcat. (API change)+    If you had:  applyToList accountFor [User "joey", User "root"]+    use instead: mconcat (map accountFor [User "joey", User "root"])+  * Makefile: Removed "run" target which was default target.+    "make" now only builds propellor, does not run it.+    Note that propellor 1.0.0 and earlier relied on this target for+    the Cron.runPropellor property's cronjob to work, so upgrading+    directly from 1.0.0 to 4.0.0 would break that cron job.+  * Remove make from propellor's dependency list; it's not used by+    propellor any longer.+  * Implemented hostChroot, as originally seen in my slides at+    Linux.Conf.Au 2017 in January. Now that it's not vaporware, it allows+    one Host to build a disk image that has all the properties of another+    Host.+  * DiskImage building properties used to propagate DNS info out from+    the chroot used to build the disk image to the Host. That is no longer+    done, since that chroot only exists as a side effect of the disk image+    creation and servers will not be running in it.+  * The IsInfo types class's propagateInfo function changed to use a+    PropagateInfo data type. (API change)+  * The action used to satisfy a property changed to Maybe (Propellor Result).+    When it is Nothing, propellor knows it can skip displaying the+    description of that property. This is mostly useful in the+    implementation of mempty. (API change)+  * The doNothing property is now simply mempty. The name was retained+    because it can be clearer than mempty in some contexts.+  * Added Apache.confEnabled.++ -- Joey Hess <id@joeyh.name>  Wed, 15 Mar 2017 15:46:42 -0400+ propellor (3.4.1) unstable; urgency=medium    * Fixed https url to propellor git repository.

@@ -44,7 +44,6 @@ 	libghc-text-dev, 	libghc-concurrent-output-dev, 	git,-	make, Description: property-based host configuration management in haskell  Propellor ensures that the system it's run in satisfies a list of  properties, taking action as necessary when a property is not yet met.

@@ -12,8 +12,8 @@ [components](http://propellor.branchable.com/components/) for details. -Properties are defined using Haskell. Edit `~/.propellor/config.hs`-to get started. There is fairly complete +Properties are defined using Haskell in the file `~/.propellor/config.hs`.+There is fairly complete  [API documentation](http://hackage.haskell.org/package/propellor/), which includes many built-in Properties for dealing with [Apt](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apt.html)

@@ -164,7 +164,7 @@ oyster = host "oyster.kitenet.net" $ props 	& standardSystem Unstable X86_64 		[ "Unreliable server. Anything here may be lost at any time!" ]-	& ipv4 "64.137.221.146"+	& ipv4 "45.62.245.55"  	& CloudAtCost.decruft 	& Ssh.hostKeys hostContext@@ -249,14 +249,17 @@ 	-- No hardware clock. 	& Apt.serviceInstalledRunning "ntp" +	-- Runs only on weekdays. 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.armAutoBuilder-		Unstable ARMEL Nothing -		(Cron.Times "15 6 * * *") "22h")+		Unstable ARMEL Nothing weekends "23h")+	-- Runs only on weekends. 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.stackAutoBuilder-		(Stable "jessie") ARMEL (Just "ancient")-		(Cron.Times "15 18 * * *") "22h")+		(Stable "jessie") ARMEL (Just "ancient") weekdays "23h")+  where+	weekdays = Cron.Times "15 6 * * 2-5"+	weekends = Cron.Times "15 6 * * 6-7"  -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed

@@ -1,5 +1,5 @@ Name: propellor-Version: 3.4.1+Version: 4.0.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>

@@ -94,7 +94,6 @@ 		, "libghc-exceptions-dev" 		, "libghc-stm-dev" 		, "libghc-text-dev"-		, "make" 		] 	fbsddeps = 		[ "gnupg"@@ -112,7 +111,6 @@ 		, "hs-exceptions" 		, "hs-stm" 		, "hs-text"-		, "gmake" 		] 	archlinuxdeps = 		[ "gnupg"@@ -131,7 +129,6 @@ 		, "haskell-exceptions" 		, "haskell-stm" 		, "haskell-text"-		, "make" 		]  installGitCommand :: Maybe System -> ShellCommand

@@ -51,15 +51,30 @@ 		) 	=> String 	-> c+	-> (PropagateInfo -> Bool) 	-> Property metatypes 	-> Property metatypes-propagateContainer containername c prop = prop+propagateContainer containername c wanted prop = prop 	`addChildren` map convert (containerProperties c)   where 	convert p = -		let n = property (getDesc p) (getSatisfy p) :: Property UnixLike+		let n = property'' (getDesc p) (getSatisfy p) :: Property UnixLike 		    n' = n 		    	`setInfoProperty` mapInfo (forceHostContext containername)-				(propagatableInfo (getInfo p))+				(propagatableInfo wanted (getInfo p)) 		   	`addChildren` map convert (getChildren p) 		in toChildProperty n'++-- | Filters out parts of the Info that should not propagate out of a+-- container.+propagatableInfo :: (PropagateInfo -> Bool) -> Info -> Info+propagatableInfo wanted (Info l) = Info $+	filter (\(InfoEntry a) -> wanted (propagateInfo a)) l++normalContainerInfo :: PropagateInfo -> Bool+normalContainerInfo PropagatePrivData = True+normalContainerInfo (PropagateInfo b) = b++onlyPrivData :: PropagateInfo -> Bool+onlyPrivData PropagatePrivData = True+onlyPrivData (PropagateInfo _) = False

@@ -66,7 +66,9 @@ 	ensure [] rs = return rs 	ensure (p:ls) rs = do 		hn <- asks hostName-		r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p)+		r <- maybe (pure NoChange)+			(actionMessageOn hn (getDesc p) . catchPropellor)+			(getSatisfy p) 		ensure ls (r <> rs)  -- | Lifts an action into the context of a different host.

@@ -46,7 +46,7 @@ 	=> OuterMetaTypesWitness outer 	-> Property (MetaTypes inner) 	-> Propellor Result-ensureProperty _ = catchPropellor . getSatisfy+ensureProperty _ = maybe (pure NoChange) catchPropellor . getSatisfy  -- The name of this was chosen to make type errors a bit more understandable. type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool@@ -62,7 +62,7 @@ 	-> (OuterMetaTypesWitness metatypes -> Propellor Result) 	-> Property (MetaTypes metatypes) property' d a =-	let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty+	let p = Property sing d (Just (a (outerMetaTypesWitness p))) mempty mempty 	in p  -- | Used to provide the metatypes of a Property to calls to 

@@ -281,10 +281,10 @@ 	{ fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) } 	deriving (Eq, Ord, Show, Typeable, Monoid) --- PrivInfo is propagated out of containers, so that propellor can see which--- hosts need it.+-- PrivInfo always propagates out of containers, so that propellor+-- can see which hosts need it. instance IsInfo PrivInfo where-	propagateInfo _ = True+	propagateInfo _ = PropagatePrivData  -- | Sets the context of any privdata that uses HostContext to the -- provided name.

@@ -16,7 +16,6 @@ 	, check 	, fallback 	, revert-	, applyToList 	-- * Property descriptions 	, describe 	, (==>)@@ -54,7 +53,6 @@ import qualified Data.Hash.MD5 as MD5 import Data.List import Control.Applicative-import Data.Foldable hiding (and, elem) import Prelude  import Propellor.Types@@ -120,13 +118,15 @@         -> CombinedType x y onChange = combineWith combiner revertcombiner   where-	combiner p hook = do+	combiner (Just p) (Just hook) = Just $ do 		r <- p 		case r of 			MadeChange -> do 				r' <- hook 				return $ r <> r' 			_ -> return r+	combiner (Just p) Nothing = Just p+	combiner Nothing _ = Nothing 	revertcombiner = (<>)  -- | Same as `onChange` except that if property y fails, a flag file@@ -144,24 +144,30 @@         -> CombinedType x y onChangeFlagOnFail flagfile = combineWith combiner revertcombiner   where-	combiner s1 s2 = do+	combiner (Just s1) s2 = Just $ do 		r1 <- s1 		case r1 of 			MadeChange -> flagFailed s2 			_ -> ifM (liftIO $ doesFileExist flagfile)-				(flagFailed s2+				( flagFailed s2 				, return r1 				)+	combiner Nothing _ = Nothing+ 	revertcombiner = (<>)-	flagFailed s = do++	flagFailed (Just s) = do 		r <- s 		liftIO $ case r of 			FailedChange -> createFlagFile 			_ -> removeFlagFile 		return r+	flagFailed Nothing = return NoChange+ 	createFlagFile = unlessM (doesFileExist flagfile) $ do 		createDirectoryIfMissing True (takeDirectory flagfile) 		writeFile flagfile ""+	 	removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile  -- | Changes the description of a property.@@ -178,11 +184,13 @@ fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2 fallback = combineWith combiner revertcombiner   where-	combiner a1 a2 = do+	combiner (Just a1) (Just a2) = Just $ do 		r <- a1 		if r == FailedChange 			then a2 			else return r+	combiner (Just a1) Nothing = Just a1+	combiner Nothing _ = Nothing 	revertcombiner = (<>)  -- | Indicates that a Property may change a particular file. When the file@@ -292,9 +300,9 @@ 	-- are added as children, so their info will propigate. 	c = withOS (getDesc a) $ \_ o -> 		if matching o a-			then getSatisfy a+			then maybe (pure NoChange) id (getSatisfy a) 			else if matching o b-				then getSatisfy b+				then maybe (pure NoChange) id (getSatisfy b) 				else unsupportedOS' 	matching Nothing _ = False 	matching (Just o) p =@@ -343,14 +351,6 @@ revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- | Apply a property to each element of a list.-applyToList-	:: (Foldable t, Functor t, Combines p p, p ~ CombinedType p p)-	=> (b -> p)-	-> t b-	-> p-prop `applyToList` xs = Data.Foldable.foldr1 before $ prop <$> xs- makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange @@ -358,7 +358,7 @@ noChange = return NoChange  doNothing :: SingI t => Property (MetaTypes t)-doNothing = property "noop property" noChange+doNothing = mempty  -- | Registers an action that should be run at the very end, after -- propellor has checks all the properties of a host.

@@ -64,6 +64,24 @@ 			`onChange` reloaded 	isenabled = boolSystem "a2query" [Param "-q", Param "-m", Param modname] +-- | Control whether an apache configuration file is enabled. +--+-- The String is the base name of the configuration, eg "charset" or "gitweb".+confEnabled :: String -> RevertableProperty DebianLike DebianLike+confEnabled confname = enable <!> disable+  where+	enable = check (not <$> isenabled)+		(cmdProperty "a2enconf" ["--quiet", confname])+			`describe` ("apache configuration enabled " ++ confname)+			`requires` installed+			`onChange` reloaded+	disable = check isenabled+		(cmdProperty "a2disconf" ["--quiet", confname])+			`describe` ("apache configuration disabled " ++ confname)+			`requires` installed+			`onChange` reloaded+	isenabled = boolSystem "a2query" [Param "-q", Param "-c", Param confname]+ -- | Make apache listen on the specified ports. -- -- Note that ports are also specified inside a site's config file,

@@ -265,7 +265,7 @@ 	:: [AptPackagePref] 	-> [(DebianSuite, PinPriority)] 	-> RevertableProperty Debian Debian-pinnedTo ps pins = (\p -> pinnedTo' p pins) `applyToList` ps+pinnedTo ps pins = mconcat (map (\p -> pinnedTo' p pins) ps) 	`describe` unwords (("pinned to " ++ showSuites):ps)   where 	showSuites = intercalate "," $ showSuite . fst <$> pins

@@ -4,6 +4,7 @@ 	debootstrapped, 	bootstrapped, 	provisioned,+	hostChroot, 	Chroot(..), 	ChrootBootstrapper(..), 	Debootstrapped(..),@@ -40,18 +41,18 @@ -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. data Chroot where-	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot+	Chroot :: ChrootBootstrapper b => FilePath -> b -> InfoPropagator -> Host -> Chroot  instance IsContainer Chroot where-	containerProperties (Chroot _ _ h) = containerProperties h-	containerInfo (Chroot _ _ h) = containerInfo h-	setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)+	containerProperties (Chroot _ _ _ h) = containerProperties h+	containerInfo (Chroot _ _ _ h) = containerInfo h+	setContainerProperties (Chroot loc b p h) ps = Chroot loc b p (setContainerProperties h ps)  chrootSystem :: Chroot -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo  instance Show Chroot where-	show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)+	show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)  -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot.@@ -115,7 +116,9 @@ -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot-bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)+bootstrapped bootstrapper location ps = c+  where+	c = Chroot location bootstrapper (propagateChrootInfo c) (host location ps)  -- | Ensures that the chroot exists and is provisioned according to its -- properties.@@ -124,15 +127,14 @@ -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux-provisioned c = provisioned' (propagateChrootInfo c) c False+provisioned c = provisioned' c False  provisioned'-	:: (Property Linux -> Property (HasInfo + Linux))-	-> Chroot+	:: Chroot 	-> Bool 	-> RevertableProperty (HasInfo + Linux) Linux-provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =-	(propigator $ setup `describe` chrootDesc c "exists")+provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly =+	(infopropigator normalContainerInfo $ setup `describe` chrootDesc c "exists") 		<!> 	(teardown `describe` chrootDesc c "removed")   where@@ -151,17 +153,20 @@ 		property ("removed " ++ loc) $ 			makeChange (removeChroot loc) -propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $-	p `setInfoProperty` chrootInfo c+type InfoPropagator = (PropagateInfo -> Bool) -> Property Linux -> Property (HasInfo + Linux) +propagateChrootInfo :: Chroot -> InfoPropagator+propagateChrootInfo c@(Chroot location _ _ _) pinfo p =+	propagateContainer location c pinfo $+		p `setInfoProperty` chrootInfo c+ 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 UnixLike-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)@@ -200,7 +205,7 @@ 		return r  toChain :: HostName -> Chroot -> Bool -> IO CmdLine-toChain parenthost (Chroot loc _ _) systemdonly = do+toChain parenthost (Chroot loc _ _ _) systemdonly = do 	onconsole <- isConsole <$> getMessageHandle 	return $ ChrootChain parenthost loc systemdonly onconsole @@ -225,7 +230,7 @@ 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@@ -245,13 +250,13 @@ 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  -- | Adding this property to a chroot prevents daemons and other services -- from being started, which is often something you want to prevent when@@ -287,3 +292,22 @@  newtype InChroot = InChroot Bool 	deriving (Typeable, Show)++-- | Generates a Chroot that has all the properties of a Host.+-- +-- Note that it's possible to create loops using this, where a host+-- contains a Chroot containing itself etc. Such loops will be detected at+-- runtime.+hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot+hostChroot h bootstrapper d = chroot+  where+	chroot = Chroot d bootstrapper pinfo h+	pinfo = propagateHostChrootInfo h chroot++-- This is different than propagateChrootInfo in that Info using+-- HostContext is not made to use the name of the chroot as its context,+-- but instead uses the hostname of the Host.+propagateHostChrootInfo :: Host -> Chroot -> InfoPropagator+propagateHostChrootInfo h c pinfo p =+	propagateContainer (hostName h) c pinfo $+		p `setInfoProperty` chrootInfo c

@@ -64,10 +64,13 @@ 	-- Increase the number of capabilities right up to the number of 	-- processors, so that A `concurrently` B `concurrently` C 	-- runs all 3 properties on different processors when possible.-	go a1 a2 = do+	go (Just a1) (Just a2) = Just $ do 		n <- liftIO getNumProcessors 		withCapabilities n $ 			concurrentSatisfy a1 a2+	go (Just a1) Nothing = Just a1+	go Nothing (Just a2) = Just a2+	go Nothing Nothing = Nothing  -- | Ensures all the properties in the list, with a specified amount of -- concurrency.@@ -101,9 +104,9 @@ 			Nothing -> return r 			Just p -> do 				hn <- asks hostName-				r' <- actionMessageOn hn-					(getDesc p)-					(getSatisfy p)+				r' <- case getSatisfy p of+					Nothing -> return NoChange+					Just a -> actionMessageOn hn (getDesc p) a 				worker q (r <> r')  -- | Run an action with the number of capabiities increased as necessary to

@@ -323,15 +323,15 @@ 	show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l)  instance IsInfo ConductorFor where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False instance IsInfo NotConductorFor where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  -- Added to Info when a host has been orchestrated. newtype Orchestrated = Orchestrated Any 	deriving (Typeable, Monoid, Show) instance IsInfo Orchestrated where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  isOrchestrated :: Orchestrated -> Bool isOrchestrated (Orchestrated v) = getAny v

@@ -50,29 +50,7 @@ -- -- 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 mempty d--- >	& osDebian Unstable X86_64--- >	& Apt.installed ["linux-image-amd64"]--- >	& User.hasPassword (User "root")--- >	& User.accountFor (User "demo")--- > 	& User.hasPassword (User "demo")--- >	& User.hasDesktopGroups (User "demo")--- > 	& ...--- > 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)--- >	]---+--  -- 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.@@ -81,6 +59,52 @@ -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image.+--+-- Example use:+--+-- > import Propellor.Property.DiskImage+-- > import Propellor.Property.Chroot+-- > +-- > foo = host "foo.example.com" $ props+-- > 	& imageBuilt "/srv/diskimages/disk.img" mychroot+-- >		MSDOS (grubBooted PC)+-- >		[ partition EXT2 `mountedAt` "/boot"+-- >			`setFlag` BootFlag+-- >		, partition EXT4 `mountedAt` "/"+-- >			`addFreeSpace` MegaBytes 100+-- >			`mountOpt` errorReadonly+-- >		, swapPartition (MegaBytes 256)+-- >		]+-- >  where+-- >	mychroot d = debootstrapped mempty d $ props+-- >		& osDebian Unstable X86_64+-- >		& Apt.installed ["linux-image-amd64"]+-- >		& User.hasPassword (User "root")+-- >		& User.accountFor (User "demo")+-- > 		& User.hasPassword (User "demo")+-- >		& User.hasDesktopGroups (User "demo")+-- > 		& ...+--+-- This can also be used with `Chroot.hostChroot` to build a disk image+-- that has all the properties of a Host. For example:+--+-- > foo :: Host+-- > foo = host "foo.example.com" $ props+-- >	& imageBuilt "/srv/diskimages/bar-disk.img"+-- >		(hostChroot bar (Debootstrapped mempty))+-- >		MSDOS (grubBooted PC)+-- >		[ partition EXT2 `mountedAt` "/boot"+-- >			`setFlag` BootFlag+-- >		, partition EXT4 `mountedAt` "/"+-- >			`addFreeSpace` MegaBytes 5000+-- >		, swapPartition (MegaBytes 256)+-- >		]+-- >+-- > bar :: Host+-- > bar = host "bar.example.com" $ props+-- >	& osDebian Unstable X86_64+-- >	& Apt.installed ["linux-image-amd64"]+-- >	& hasPassword (User "root") imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt = imageBuilt' False @@ -106,7 +130,7 @@ 		| otherwise = doNothing 	chrootdir = img ++ ".chroot" 	chroot =-		let c = mkchroot chrootdir+		let c = propprivdataonly $ mkchroot chrootdir 		in setContainerProps c $ containerProps c 			-- Before ensuring any other properties of the chroot, 			-- avoid starting services. Reverted by imageFinalized.@@ -114,6 +138,9 @@ 			-- First stage finalization. 			& fst final 			& cachesCleaned+	-- Only propagate privdata Info from this chroot, nothing else.+	propprivdataonly (Chroot.Chroot d b ip h) =+		Chroot.Chroot d b (const $ ip onlyPrivData) h  -- | This property is automatically added to the chroot when building a -- disk image. It cleans any caches of information that can be omitted;

@@ -184,8 +184,9 @@ 	image = getImageName ctr  propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $-	p `addInfoProperty` dockerinfo+propagateContainerInfo ctr@(Container _ h) p = +	propagateContainer cn ctr normalContainerInfo $+		p `addInfoProperty` dockerinfo   where 	dockerinfo = dockerInfo $ 		mempty { _dockerContainers = M.singleton cn h }

@@ -22,7 +22,7 @@ -- -- See "DESKTOP INTEGRATION" in firejail(1). jailed :: [String] -> Property DebianLike-jailed ps = (jailed' `applyToList` ps)+jailed ps = mconcat (map jailed' ps) 	`requires` installed 	`describe` unwords ("firejail jailed":ps) 

@@ -39,7 +39,7 @@ newtype PkgUpdate = PkgUpdate String 	deriving (Typeable, Monoid, Show) instance IsInfo PkgUpdate where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  pkgUpdated :: PkgUpdate -> Bool pkgUpdated (PkgUpdate _) = True@@ -55,8 +55,9 @@  newtype PkgUpgrade = PkgUpgrade String 	deriving (Typeable, Monoid, Show)+ instance IsInfo PkgUpgrade where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  pkgUpgraded :: PkgUpgrade -> Bool pkgUpgraded (PkgUpgrade _) = True

@@ -21,7 +21,7 @@ 	deriving (Typeable, Monoid, Show)  instance IsInfo PoudriereConfigured where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  poudriereConfigured :: PoudriereConfigured -> Bool poudriereConfigured (PoudriereConfigured _) = True

@@ -53,7 +53,7 @@ combineSatisfy :: [ChildProperty] -> Result -> Propellor Result combineSatisfy [] rs = return rs combineSatisfy (p:ps) rs = do-	r <- catchPropellor $ getSatisfy p+	r <- maybe (pure NoChange) catchPropellor (getSatisfy p) 	case r of 		FailedChange -> return FailedChange 		_ -> combineSatisfy ps (r <> rs)

@@ -228,23 +228,29 @@ 		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") 		`requires` Ssh.authorizedKeys (User "family") (Context "git.kitenet.net") 		`requires` User.accountFor (User "family")-	& Apt.installed ["git", "rsync", "gitweb"]+	& Apt.installed ["git", "rsync", "cgit"] 	& Apt.installed ["git-annex"] 	& Apt.installed ["kgb-client"] 	& File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext 		`requires` File.dirExists "/etc/kgb-bot/" 	& Git.daemonRunning "/srv/git"-	& "/etc/gitweb.conf" `File.containsLines`-		[ "$projectroot = '/srv/git';"-		, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"-		, "# disable snapshot download; overloads server"-		, "$feature{'snapshot'}{'default'} = [];"+	& "/etc/cgitrc" `File.hasContent`+		[ "clone-url=https://git.joeyh.name/git/$CGIT_REPO_URL git://git.joeyh.name/$CGIT_REPO_URL"+		, "css=/cgit-css/cgit.css"+		, "logo=/cgit-css/cgit.png"+		, "enable-http-clone=1"+		, "root-title=Joey's git repositories"+		, "root-desc="+		, "enable-index-owner=0"+		, "snapshots=tar.gz"+		, "enable-git-config=1"+		, "scan-path=/srv/git" 		]-		`describe` "gitweb configured"-	-- Repos push on to github.-	& Ssh.knownHost hosts "github.com" (User "joey")-	-- I keep the website used for gitweb checked into git..+		`describe` "cgit configured"+	-- I keep the website used for git.kitenet.net/git.joeyh.name checked into git.. 	& Git.cloned (User "root") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing+	-- Don't need global apache configuration for cgit.+	! Apache.confEnabled "cgit" 	& website "git.kitenet.net" 	& website "git.joeyh.name" 	& Apache.modEnabled "cgi"

@@ -227,7 +227,7 @@ 	deriving (Eq, Ord, Typeable, Show)  instance IsInfo HostKeyInfo where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  instance Monoid HostKeyInfo where 	mempty = HostKeyInfo M.empty@@ -248,7 +248,7 @@ 	deriving (Eq, Ord, Typeable, Show)  instance IsInfo UserKeyInfo where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  instance Monoid UserKeyInfo where 	mempty = UserKeyInfo M.empty

@@ -259,7 +259,7 @@ -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux-nspawned c@(Container name (Chroot.Chroot loc builder _) h) =+nspawned c@(Container name (Chroot.Chroot loc builder _ _) h) = 	p `describe` ("nspawned " ++ name)   where 	p :: RevertableProperty (HasInfo + Linux) Linux@@ -271,7 +271,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 properties.-	chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True+	chrootprovisioned = Chroot.provisioned' chroot True  	-- Use nsenter to enter container and and run propellor to 	-- finish provisioning.@@ -281,7 +281,7 @@ 			<!> 		doNothing -	chroot = Chroot.Chroot loc builder h+	chroot = Chroot.Chroot loc builder (Chroot.propagateChrootInfo chroot) h  -- | Sets up the service file for the container, and then starts -- it running.

@@ -12,6 +12,7 @@ 	  Host(..) 	, Property(..) 	, property+	, property'' 	, Desc 	, RevertableProperty(..) 	, (<!>)@@ -56,7 +57,6 @@ -- | The core data type of Propellor, this represents a property -- that the system should have, with a descrition, and an action to ensure -- it has the property.--- that have the property. -- -- There are different types of properties that target different OS's, -- and so have different metatypes. @@ -67,7 +67,7 @@ -- -- There are many associated type families, which are mostly used -- internally, so you needn't worry about them.-data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]+data Property metatypes = Property metatypes Desc (Maybe (Propellor Result)) Info [ChildProperty]  instance Show (Property metatypes) where 	show p = "property " ++ show (getDesc p)@@ -90,11 +90,18 @@ 	=> Desc 	-> Propellor Result 	-> Property (MetaTypes metatypes)-property d a = Property sing d a mempty mempty+property d a = Property sing d (Just a) mempty mempty +property''+	:: SingI metatypes+	=> Desc+	-> Maybe (Propellor Result)+	-> Property (MetaTypes metatypes)+property'' d a = Property sing d a mempty mempty+ -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes-adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c+adjustPropertySatisfy (Property t d s i c) f = Property t d (f <$> s) i c  -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted.@@ -148,7 +155,7 @@ type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y)) type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y)) -type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result+type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (Propellor Result)  class Combines x y where 	-- | Combines together two properties, yielding a property that@@ -198,3 +205,35 @@  instance TightenTargets Property where 	tightenTargets (Property _ d a i c) = Property sing d a i c++-- | Any type of Property is a monoid. When properties x and y are+-- appended together, the resulting property has a description like+-- "x and y". Note that when x fails to be ensured, it will not+-- try to ensure y.+instance SingI metatypes => Monoid (Property (MetaTypes metatypes))+  where+	mempty = Property sing "noop property" Nothing mempty mempty+	mappend (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =+	  	Property sing d (a1 <> a2) (i1 <> i2) (c1 <> c2)+	  where+		-- Avoid including "noop property" in description+		-- when using eg mconcat.+		d = case (a1, a2) of+			(Just _, Just _) -> d1 <> " and " <> d2+			(Just _, Nothing) -> d1+			(Nothing, Just _) -> d2+			(Nothing, Nothing) -> d1++-- | Any type of RevertableProperty is a monoid. When revertable +-- properties x and y are appended together, the resulting revertable+-- property has a description like "x and y".+-- Note that when x fails to be ensured, it will not try to ensure y.+instance+	( Monoid (Property setupmetatypes)+	, Monoid (Property undometatypes)+	)+	=> Monoid (RevertableProperty setupmetatypes undometatypes)+  where+	mempty = RevertableProperty mempty mempty+	mappend (RevertableProperty s1 u1) (RevertableProperty s2 u2) =+		RevertableProperty (s1 <> s2) (u2 <> u1)

@@ -16,7 +16,7 @@ 	deriving (Show, Typeable)  instance IsInfo ChrootInfo where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  instance Monoid ChrootInfo where 	mempty = ChrootInfo mempty mempty

@@ -48,9 +48,10 @@ instance LiftPropellor IO where 	liftPropellor = liftIO +-- | When two actions are appended together, the second action+-- is only run if the first action does not fail. instance Monoid (Propellor Result) where 	mempty = return NoChange-	-- | The second action is only run if the first action does not fail. 	mappend x y = do 		rx <- x 		case rx of@@ -71,7 +72,7 @@  -- | Since there are many different types of Properties, they cannot be put -- into a list. The simplified ChildProperty can be put into a list.-data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]+data ChildProperty = ChildProperty Desc (Maybe (Propellor Result)) Info [ChildProperty]    instance Show ChildProperty where 	show p = "property " ++ show (getDesc p)@@ -92,7 +93,7 @@ 	-- | Gets the action that can be run to satisfy a Property. 	-- You should never run this action directly. Use 	-- 'Propellor.EnsureProperty.ensureProperty` instead.-	getSatisfy :: p -> Propellor Result+	getSatisfy :: p -> Maybe (Propellor Result)  instance IsProp ChildProperty where 	setDesc (ChildProperty _ a i c) d = ChildProperty d a i c

@@ -28,7 +28,7 @@ 	deriving (Show, Eq, Ord, Monoid, Typeable)  instance IsInfo AliasesInfo where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  toAliasesInfo :: [HostName] -> AliasesInfo toAliasesInfo l = AliasesInfo (S.fromList l)@@ -45,7 +45,7 @@ -- | DNS Info is propagated, so that eg, aliases of a container -- are reflected in the dns for the host where it runs. instance IsInfo DnsInfo where-	propagateInfo _ = True+	propagateInfo _ = PropagateInfo True  -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf@@ -157,7 +157,7 @@ 	deriving (Eq, Ord, Show, Typeable)  instance IsInfo NamedConfMap where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a

@@ -16,7 +16,7 @@ 	deriving (Show, Typeable)  instance IsInfo DockerInfo where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  instance Monoid DockerInfo where 	mempty = DockerInfo mempty mempty

@@ -1,13 +1,14 @@ {-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}  module Propellor.Types.Info (-	Info,+	Info(..),+	InfoEntry(..), 	IsInfo(..),+	PropagateInfo(..), 	addInfo, 	toInfo, 	fromInfo, 	mapInfo,-	propagatableInfo, 	InfoVal(..), 	fromInfoVal, 	Typeable,@@ -44,8 +45,14 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where 	-- | Should info of this type be propagated out of a 	-- container to its Host?-	propagateInfo :: v -> Bool+	propagateInfo :: v -> PropagateInfo +data PropagateInfo+	= PropagateInfo Bool+	| PropagatePrivData+	-- ^ Info about PrivData generally will be propigated even in cases+	-- where other Info is not, so it treated specially.+ -- | Any value in the `IsInfo` type class can be added to an Info. addInfo :: IsInfo v => Info -> v -> Info addInfo (Info l) v = Info (InfoEntry v:l)@@ -68,11 +75,6 @@ 		Nothing -> i 		Just v -> InfoEntry (f v) --- | Filters out parts of the Info that should not propagate out of a--- container.-propagatableInfo :: Info -> Info-propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l)- -- | Use this to put a value in Info that is not a monoid. -- The last value set will be used. This info does not propagate -- out of a container.@@ -85,7 +87,7 @@ 	mappend v NoInfoVal = v  instance (Typeable v, Show v) => IsInfo (InfoVal v) where-	propagateInfo _ = False+	propagateInfo _ = PropagateInfo False  fromInfoVal :: InfoVal v -> Maybe v fromInfoVal NoInfoVal = Nothing