propellor 2.14.0 → 2.15.0

raw patch · 41 files changed

+648/−178 lines, 41 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +32/−0
• config-joey.hs +2/−1
• debian/changelog +32/−0
• propellor.cabal +4/−1
• src/Propellor/Property.hs +79/−20
• src/Propellor/Property/Apache.hs +7/−7
• src/Propellor/Property/Apt.hs +25/−15
• src/Propellor/Property/Chroot.hs +1/−0
• src/Propellor/Property/Cmd.hs +39/−10
• src/Propellor/Property/DebianMirror.hs +3/−2
• src/Propellor/Property/DiskImage.hs +5/−1
• src/Propellor/Property/Docker.hs +8/−3
• src/Propellor/Property/Fail2Ban.hs +30/−0
• src/Propellor/Property/File.hs +8/−8
• src/Propellor/Property/Git.hs +31/−16
• src/Propellor/Property/Group.hs +1/−1
• src/Propellor/Property/Grub.hs +7/−5
• src/Propellor/Property/HostingProvider/CloudAtCost.hs +2/−2
• src/Propellor/Property/Hostname.hs +22/−19
• src/Propellor/Property/Journald.hs +2/−1
• src/Propellor/Property/Locale.hs +80/−0
• src/Propellor/Property/Mount.hs +1/−0
• src/Propellor/Property/Network.hs +1/−0
• src/Propellor/Property/Nginx.hs +1/−1
• src/Propellor/Property/Parted.hs +4/−3
• src/Propellor/Property/Partition.hs +3/−2
• src/Propellor/Property/Postfix.hs +28/−3
• src/Propellor/Property/Prosody.hs +1/−1
• src/Propellor/Property/Reboot.hs +1/−0
• src/Propellor/Property/Rsync.hs +1/−0
• src/Propellor/Property/Service.hs +4/−4
• src/Propellor/Property/SiteSpecific/Branchable.hs +1/−1
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +6/−1
• src/Propellor/Property/SiteSpecific/GitHome.hs +2/−0
• src/Propellor/Property/SiteSpecific/IABak.hs +12/−7
• src/Propellor/Property/SiteSpecific/JoeySites.hs +15/−3
• src/Propellor/Property/Ssh.hs +2/−2
• src/Propellor/Property/Systemd.hs +22/−12
• src/Propellor/Property/User.hs +40/−25
• src/Propellor/Property/Uwsgi.hs +1/−1
• src/Propellor/Types/ResultCheck.hs +82/−0

@@ -1,3 +1,35 @@+propellor (2.15.0) unstable; urgency=medium++  * Added UncheckedProperty type, along with unchecked to indicate a+    Property needs its result checked, and checkResult and changesFile+    to check for changes.+  * Properties that run an arbitrary command, such as cmdProperty+    and scriptProperty are converted to use UncheckedProperty, since+    they cannot tell on their own if the command truely made a change or not.+    (API Change)+    Transition guide:+    - When GHC complains about an UncheckedProperty, add:+    	`assume` MadeChange+      (Since these properties used to always return MadeChange, that+      change is always safe to make.)+    - Or, if you know that the command should modifiy a file, use:+    	`changesFile` filename+  * The `trivial` combinator has been removed. (API change)+    Instead, use:+    	`assume` NoChange+    Or, better, use changesFile or checkResult to accurately report+    when a property makes a change.+  * A few properties have had their Result improved, for example+    Apt.buldDep and Apt.autoRemove now check if a change was made or not.+  * User.hasDesktopGroups changed to avoid trying to add the user to+    groups that don't exist.+  * Added Postfix.saslPasswdSet.+  * Added Propellor.Property.Locale.+    Thanks, Sean Whitton.+  * Added Propellor.Property.Fail2Ban.++ -- Joey Hess <id@joeyh.name>  Sun, 06 Dec 2015 15:33:51 -0400+ propellor (2.14.0) unstable; urgency=medium    * Add Propellor.Property.PropellorRepo.hasOriginUrl, an explicit way to

@@ -25,6 +25,7 @@ import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald import qualified Propellor.Property.Chroot as Chroot+import qualified Propellor.Property.Fail2Ban as Fail2Ban import qualified Propellor.Property.Aiccu as Aiccu import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost@@ -221,7 +222,7 @@ 	& Journald.systemMaxUse "500MiB" 	& Ssh.passwordAuthentication True 	-- Since ssh password authentication is allowed:-	& Apt.serviceInstalledRunning "fail2ban"+	& Fail2Ban.installed 	& Obnam.backupEncrypted "/" (Cron.Times "33 1 * * *") 		[ "--repository=sftp://joey@eubackup.kitenet.net/~/lib/backup/kite.obnam" 		, "--client-name=kitenet.net"

@@ -1,3 +1,35 @@+propellor (2.15.0) unstable; urgency=medium++  * Added UncheckedProperty type, along with unchecked to indicate a+    Property needs its result checked, and checkResult and changesFile+    to check for changes.+  * Properties that run an arbitrary command, such as cmdProperty+    and scriptProperty are converted to use UncheckedProperty, since+    they cannot tell on their own if the command truely made a change or not.+    (API Change)+    Transition guide:+    - When GHC complains about an UncheckedProperty, add:+    	`assume` MadeChange+      (Since these properties used to always return MadeChange, that+      change is always safe to make.)+    - Or, if you know that the command should modifiy a file, use:+    	`changesFile` filename+  * The `trivial` combinator has been removed. (API change)+    Instead, use:+    	`assume` NoChange+    Or, better, use changesFile or checkResult to accurately report+    when a property makes a change.+  * A few properties have had their Result improved, for example+    Apt.buldDep and Apt.autoRemove now check if a change was made or not.+  * User.hasDesktopGroups changed to avoid trying to add the user to+    groups that don't exist.+  * Added Postfix.saslPasswdSet.+  * Added Propellor.Property.Locale.+    Thanks, Sean Whitton.+  * Added Propellor.Property.Fail2Ban.++ -- Joey Hess <id@joeyh.name>  Sun, 06 Dec 2015 15:33:51 -0400+ propellor (2.14.0) unstable; urgency=medium    * Add Propellor.Property.PropellorRepo.hasOriginUrl, an explicit way to

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.14.0+Version: 2.15.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -80,6 +80,7 @@     Propellor.Property.Dns     Propellor.Property.DnsSec     Propellor.Property.Docker+    Propellor.Property.Fail2Ban     Propellor.Property.File     Propellor.Property.Firewall     Propellor.Property.Git@@ -90,6 +91,7 @@     Propellor.Property.Kerberos     Propellor.Property.List     Propellor.Property.LightDM+    Propellor.Property.Locale     Propellor.Property.Logcheck     Propellor.Property.Mount     Propellor.Property.Network@@ -141,6 +143,7 @@     Propellor.Types.OS     Propellor.Types.PrivData     Propellor.Types.Result+    Propellor.Types.ResultCheck     Propellor.Types.CmdLine   Other-Modules:     Propellor.Bootstrap

@@ -11,7 +11,6 @@ 	, flagFile' 	, check 	, fallback-	, trivial 	, revert 	-- * Property descriptions 	, describe@@ -25,19 +24,34 @@ 	, noChange 	, doNothing 	, endAction+	-- * Property result checking+	, UncheckedProperty+	, unchecked+	, changesFile+	, changesFileContent+	, isNewerThan+	, checkResult+	, Checkable+	, assume ) where  import System.Directory import System.FilePath import Control.Monad+import Control.Applicative import Data.Monoid import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict+import System.Posix.Files+import qualified Data.Hash.MD5 as MD5  import Propellor.Types+import Propellor.Types.ResultCheck import Propellor.Info import Propellor.Exception+import Utility.Exception import Utility.Monad+import Utility.Misc  -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met.@@ -155,14 +169,6 @@ ensureProperty :: Property NoInfo -> Propellor Result ensureProperty = catchPropellor . propertySatisfy --- | Makes a Property only need to do anything when a test succeeds.-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. fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2@@ -175,18 +181,71 @@ 			else return r 	revertcombiner = (<>) --- | Marks a Property as trivial. It can only return FailedChange or--- NoChange. +-- | Indicates that a Property may change a particular file. When the file+-- is modified in any way (including changing its permissions or mtime),+-- the property will return MadeChange instead of NoChange.+changesFile :: Checkable p i => p i -> FilePath -> Property i+changesFile p f = checkResult getstat comparestat p+  where+	getstat = catchMaybeIO $ getSymbolicLinkStatus f+	comparestat oldstat = do+		newstat <- getstat+		return $ if samestat oldstat newstat then NoChange else MadeChange+	samestat Nothing Nothing = True+	samestat (Just a) (Just b) = and+		-- everything except for atime+		[ deviceID a == deviceID b+		, fileID a == fileID b+		, fileMode a == fileMode b+		, fileOwner a == fileOwner b+		, fileGroup a == fileGroup b+		, specialDeviceID a == specialDeviceID b+		, fileSize a == fileSize b+		, modificationTimeHiRes a == modificationTimeHiRes b+		, isBlockDevice a == isBlockDevice b+		, isCharacterDevice a == isCharacterDevice b+		, isNamedPipe a == isNamedPipe b+		, isRegularFile a == isRegularFile b+		, isDirectory a == isDirectory b+		, isSymbolicLink a == isSymbolicLink b+		, isSocket a == isSocket b+		]+	samestat _ _ = False++-- | Like `changesFile`, but compares the content of the file.+-- Changes to mtime etc that do not change file content are treated as+-- NoChange.+changesFileContent :: Checkable p i => p i -> FilePath -> Property i+changesFileContent p f = checkResult getmd5 comparemd5 p+  where+	getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f+	comparemd5 oldmd5 = do+		newmd5 <- getmd5+		return $ if oldmd5 == newmd5 then NoChange else MadeChange++-- | Determines if the first file is newer than the second file. ----- Useful when it's just as expensive to check if a change needs--- to be made as it is to just idempotently assure the property is--- satisfied. For example, chmodding a file.-trivial :: Property i -> Property i-trivial p = adjustPropertySatisfy p $ \satisfy -> do-	r <- satisfy-	if r == MadeChange-		then return NoChange-		else return r+-- This can be used with `check` to only run a command when a file+-- has changed.+--+-- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")+-- > 	(cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db+--+-- Or it can be used with `checkResult` to test if a command made a change.+--+-- > checkResult (return ())+-- > 	(\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases")+-- > 	(cmdProperty "newaliases" [])+--+-- (If one of the files does not exist, the file that does exist is+-- considered to be the newer of the two.)+isNewerThan :: FilePath -> FilePath -> IO Bool+isNewerThan x y = do+	mx <- mtime x+	my <- mtime y+	return (mx > my)+  where+	mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f  -- | Makes a property that is satisfied differently depending on the host's -- operating system. 

@@ -37,8 +37,8 @@ 		[ siteAvailable hn cf 			`requires` installed 			`onChange` reloaded-		, check (not <$> isenabled) $-			cmdProperty "a2ensite" ["--quiet", hn]+		, check (not <$> isenabled) +			(cmdProperty "a2ensite" ["--quiet", hn]) 				`requires` installed 				`onChange` reloaded 		]@@ -49,7 +49,7 @@ siteDisabled hn = combineProperties 	("apache site disabled " ++ hn)  	(map File.notPresent (siteCfg hn))-		`onChange` cmdProperty "a2dissite" ["--quiet", hn]+		`onChange` (cmdProperty "a2dissite" ["--quiet", hn] `assume` MadeChange) 		`requires` installed 		`onChange` reloaded @@ -62,13 +62,13 @@ modEnabled :: String -> RevertableProperty NoInfo modEnabled modname = enable <!> disable   where-	enable = check (not <$> isenabled) $-		cmdProperty "a2enmod" ["--quiet", modname]+	enable = check (not <$> isenabled)+		(cmdProperty "a2enmod" ["--quiet", modname]) 			`describe` ("apache module enabled " ++ modname) 			`requires` installed 			`onChange` reloaded-	disable = check isenabled $ -		cmdProperty "a2dismod" ["--quiet", modname]+	disable = check isenabled+		(cmdProperty "a2dismod" ["--quiet", modname]) 			`describe` ("apache module disabled " ++ modname) 			`requires` installed 			`onChange` reloaded

@@ -108,7 +108,7 @@   where 	f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> Property NoInfo+runApt :: [String] -> UncheckedProperty NoInfo runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv  noninteractiveEnv :: [(String, String)]@@ -119,10 +119,12 @@  update :: Property NoInfo update = runApt ["update"]+	`assume` MadeChange 	`describe` "apt update"  upgrade :: Property NoInfo upgrade = runApt ["-y", "dist-upgrade"]+	`assume` MadeChange 	`describe` "apt dist-upgrade"  type Package = String@@ -134,15 +136,16 @@ installed' params ps = robustly $ check (isInstallable ps) go 	`describe` (unwords $ "apt installed":ps)   where-	go = runApt $ params ++ ["install"] ++ ps+	go = runApt (params ++ ["install"] ++ ps)  installedBackport :: [Package] -> Property NoInfo-installedBackport ps = trivial $ withOS desc $ \o -> case o of+installedBackport ps = withOS desc $ \o -> case o of 	Nothing -> error "cannot install backports; os not declared" 	(Just (System (Debian suite) _)) -> case backportSuite suite of 		Nothing -> notsupported o-		Just bs -> ensureProperty $ runApt $-			["install", "-t", bs, "-y"] ++ ps+		Just bs -> ensureProperty $ +			runApt (["install", "-t", bs, "-y"] ++ ps)+				`changesFile` dpkgStatus 	_ -> notsupported o   where 	desc = (unwords $ "apt installed backport":ps)@@ -153,13 +156,12 @@ installedMin = installed' ["--no-install-recommends", "-y"]  removed :: [Package] -> Property NoInfo-removed ps = check (or <$> isInstalled' ps) go+removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) 	`describe` (unwords $ "apt removed":ps)-  where-	go = runApt $ ["-y", "remove"] ++ ps  buildDep :: [Package] -> Property NoInfo-buildDep ps = robustly go+buildDep ps = robustly $ go+	`changesFile` dpkgStatus 	`describe` (unwords $ "apt build-dep":ps)   where 	go = runApt $ ["-y", "build-dep"] ++ ps@@ -168,10 +170,11 @@ -- in the specifed directory, with a dummy package also -- installed so that autoRemove won't remove them. buildDepIn :: FilePath -> Property NoInfo-buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]+buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv+	`changesFile` dpkgStatus+	`requires` installedMin ["devscripts", "equivs"]   where-	go = cmdPropertyEnv "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]-			noninteractiveEnv+	cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"  -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry.@@ -209,6 +212,7 @@  autoRemove :: Property NoInfo autoRemove = runApt ["-y", "autoremove"]+	`changesFile` dpkgStatus 	`describe` "apt autoremove"  -- | Enables unattended upgrades. Revert to disable.@@ -259,6 +263,7 @@ 							hPutStrLn h $ unwords [package, tmpl, tmpltype, value] 						hClose h 	reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv+		`assume` MadeChange  -- | Ensures that a service is installed and running. --@@ -295,13 +300,18 @@ -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space. cacheCleaned :: Property NoInfo-cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"]+cacheCleaned = cmdProperty "apt-get" ["clean"]+	`assume` NoChange 	`describe` "apt cache cleaned"  -- | Add a foreign architecture to dpkg and apt. hasForeignArch :: String -> Property NoInfo-hasForeignArch arch = check notAdded add+hasForeignArch arch = check notAdded (add `before` update) 	`describe` ("dpkg has foreign architecture " ++ arch)   where 	notAdded = (not . elem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"]-	add = cmdProperty "dpkg" ["--add-architecture", arch] `before` update+	add = cmdProperty "dpkg" ["--add-architecture", arch]+		`assume` MadeChange++dpkgStatus :: FilePath+dpkgStatus = "/var/lib/dpkg/status"

@@ -74,6 +74,7 @@ extractTarball target src = toProp . 	check (unpopulated target) $ 		cmdProperty "tar" params+			`assume` MadeChange 			`requires` File.dirExists target   where 	params =

@@ -1,7 +1,32 @@ {-# LANGUAGE PackageImports #-} +-- | This module lets you construct Properties by running commands and+-- scripts. To get from an `UncheckedProperty` to a `Property`, it's+-- up to the user to check if the command made a change to the system. +--+-- The best approach is to `check` a property, so that the command is only+-- run when it needs to be. With this method, you avoid running the+-- `cmdProperty` unnecessarily.+--+-- > check (not <$> userExists "bob")+-- > 	(cmdProperty "useradd" ["bob"])+--+-- Sometimes it's just as expensive to check a property as it would be to+-- run the command that ensures the property. So you can let the command+-- run every time, and use `changesFile` or `checkResult` to determine if+-- anything changed:+--+-- > cmdProperty "chmod" ["600", "/etc/secret"]+-- > 	`changesFile` "/etc/secret"+--+-- Or you can punt and `assume` a change was made, but then propellor will+-- always say it make a change, and `onChange` will always fire.+--+-- > cmdProperty "service" ["foo", "reload"]+-- > 	`assume` MadeChange+ module Propellor.Property.Cmd (-	-- * Properties for running commands and scripts+	-- * Constricting properties running commands and scripts 	cmdProperty, 	cmdProperty', 	cmdPropertyEnv,@@ -32,22 +57,26 @@ -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success.-cmdProperty :: String -> [String] -> Property NoInfo+cmdProperty :: String -> [String] -> UncheckedProperty NoInfo cmdProperty cmd params = cmdProperty' cmd params id -cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> Property NoInfo-cmdProperty' cmd params mkprocess = property desc $ liftIO $ do-	toResult <$> boolSystem' cmd (map Param params) mkprocess+cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty NoInfo+cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $+	cmdResult <$> boolSystem' cmd (map Param params) mkprocess   where 	desc = unwords $ cmd : params +cmdResult :: Bool -> Result+cmdResult False = FailedChange+cmdResult True = NoChange+ -- | A property that can be satisfied by running a command, -- with added environment variables in addition to the standard -- environment.-cmdPropertyEnv :: String -> [String] -> [(String, String)] -> Property NoInfo-cmdPropertyEnv cmd params env = property desc $ liftIO $ do+cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty NoInfo+cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do 	env' <- addEntries env <$> getEnvironment-	toResult <$> boolSystemEnv cmd (map Param params) (Just env')+	cmdResult <$> boolSystemEnv cmd (map Param params) (Just env')   where 	desc = unwords $ cmd : params @@ -55,14 +84,14 @@ type Script = [String]  -- | A property that can be satisfied by running a script.-scriptProperty :: Script -> Property NoInfo+scriptProperty :: Script -> UncheckedProperty NoInfo scriptProperty script = cmdProperty "sh" ["-c", shellcmd]   where 	shellcmd = intercalate " ; " ("set -e" : script)  -- | A property that can satisfied by running a script -- as user (cd'd to their home directory).-userScriptProperty :: User -> Script -> Property NoInfo+userScriptProperty :: User -> Script -> UncheckedProperty NoInfo userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user]   where 	shellcmd = intercalate " ; " ("set -e" : "cd" : script)

@@ -126,8 +126,9 @@ 	, User.accountFor (User "debmirror") 	, File.dirExists dir 	, File.ownerGroup dir (User "debmirror") (Group "debmirror")-	, check (not . and <$> mapM suitemirrored suites) $ cmdProperty "debmirror" args-		`describe` "debmirror setup"+	, check (not . and <$> mapM suitemirrored suites)+		(cmdProperty "debmirror" args)+			`describe` "debmirror setup" 	, Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $ 		unwords ("/usr/bin/debmirror" : args) 	]

@@ -287,15 +287,19 @@ 		, mounted "sysfs" "sys" (inmnt "/sys") mempty 		-- update the initramfs so it gets the uuid of the root partition 		, inchroot "update-initramfs" ["-u"]+			`assume` MadeChange 		-- work around for http://bugs.debian.org/802717-		 , check haveosprober $ inchroot "chmod" ["-x", osprober]+		, check haveosprober $ inchroot "chmod" ["-x", osprober] 		, inchroot "update-grub" []+			`assume` MadeChange 		, check haveosprober $ inchroot "chmod" ["+x", osprober] 		, inchroot "grub-install" [wholediskloopdev]+			`assume` MadeChange 		-- 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" []+			`assume` NoChange 		] 	  where 	  	-- cannot use </> since the filepath is absolute

@@ -160,6 +160,7 @@   where 	msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory 	built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir+		`assume` MadeChange 	workDir p = p { cwd = Just directory } 	image = getImageName ctr @@ -169,6 +170,7 @@   where 	msg = "docker image " ++ (imageIdentifier image) ++ " pulled" 	pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]+		`assume` MadeChange 	image = getImageName ctr  propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo@@ -224,8 +226,11 @@ -- the pam config, to work around <https://github.com/docker/docker/issues/5663> -- which affects docker 1.2.0. tweaked :: Property NoInfo-tweaked = trivial $-	cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"]+tweaked = cmdProperty "sh"+	[ "-c"+	, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"+	]+	`assume` NoChange 	`describe` "tweaked for docker"  -- | Configures the kernel to respect docker memory limits. @@ -237,7 +242,7 @@ memoryLimited :: Property NoInfo memoryLimited = "/etc/default/grub" `File.containsLine` cfg 	`describe` "docker memory limited" -	`onChange` cmdProperty "update-grub" []+	`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)   where 	cmdline = "cgroup_enable=memory swapaccount=1" 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""

@@ -0,0 +1,30 @@+module Propellor.Property.Fail2Ban where++import Propellor.Base+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service+import Propellor.Property.ConfFile++installed :: Property NoInfo+installed = Apt.serviceInstalledRunning "fail2ban"++reloaded :: Property NoInfo+reloaded = Service.reloaded "fail2ban"++type Jail = String++-- | By default, fail2ban only enables the ssh jail, but many others+-- are available to be enabled, for example "postfix-sasl"+jailEnabled :: Jail -> Property NoInfo+jailEnabled name = jailConfigured name "enabled" "true"+	`onChange` reloaded++-- | Configures a jail. For example:+--+-- > jailConfigured "sshd" "port" "2222"+jailConfigured :: Jail -> IniKey -> String -> Property NoInfo+jailConfigured name key value = +	jailConfFile name `containsIniSetting` (name, key, value)++jailConfFile :: Jail -> FilePath+jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf"

@@ -158,19 +158,19 @@  -- | Ensures that a file/dir has the specified owner and group. ownerGroup :: FilePath -> User -> Group -> Property NoInfo-ownerGroup f (User owner) (Group group) = property (f ++ " owner " ++ og) $ do-	r <- ensureProperty $ cmdProperty "chown" [og, f]-	if r == FailedChange-		then return r-		else noChange+ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)   where+	p = cmdProperty "chown" [og, f]+		`changesFile` f 	og = owner ++ ":" ++ group  -- | Ensures that a file/dir has the specfied mode. mode :: FilePath -> FileMode -> Property NoInfo-mode f v = property (f ++ " mode " ++ show v) $ do-	liftIO $ modifyFileMode f (const v)-	noChange+mode f v = p `changesFile` f+  where+	p = property (f ++ " mode " ++ show v) $ do+		liftIO $ modifyFileMode f (const v)+		return NoChange  -- | A temp file to use when writing new content for a file. --

@@ -79,18 +79,20 @@ 			whenM (doesDirectoryExist dir) $ 				removeDirectoryRecursive dir 			createDirectoryIfMissing True (takeDirectory dir)-		ensureProperty $ userScriptProperty owner $ catMaybes-			-- The </dev/null fixes an intermittent-			-- "fatal: read error: Bad file descriptor"-			-- when run across ssh with propellor --spin-			[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"-			, Just $ "cd " ++ shellEscape dir-			, ("git checkout " ++) <$> mbranch-			-- In case this repo is exposted via the web,-			-- although the hook to do this ongoing is not-			-- installed here.-			, Just "git update-server-info"-			]+		ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds)+			`assume` MadeChange+	checkoutcmds = +		-- The </dev/null fixes an intermittent+		-- "fatal: read error: Bad file descriptor"+		-- when run across ssh with propellor --spin+		[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"+		, Just $ "cd " ++ shellEscape dir+		, ("git checkout " ++) <$> mbranch+		-- In case this repo is exposted via the web,+		-- although the hook to do this ongoing is not+		-- installed here.+		, Just "git update-server-info"+		]  isGitDir :: FilePath -> IO Bool isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir])@@ -103,27 +105,40 @@ 		NotShared -> 			[ ownerGroup repo user (userGroup user) 			, userScriptProperty user ["git init --bare --shared=false " ++ shellEscape repo]+				`assume` MadeChange 			] 		SharedAll -> 			[ ownerGroup repo user (userGroup user) 			, userScriptProperty user ["git init --bare --shared=all " ++ shellEscape repo]+				`assume` MadeChange 			] 		Shared group' -> 			[ ownerGroup repo user group' 			, userScriptProperty user ["git init --bare --shared=group " ++ shellEscape repo]+				`assume` MadeChange 			]   where 	isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])  -- | Set a key value pair in a git repo's configuration. repoConfigured :: FilePath -> (String, String) -> Property NoInfo-repo `repoConfigured` (key, value) =-	trivial $ userScriptProperty (User "root")+repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $+	userScriptProperty (User "root") 		[ "cd " ++ repo 		, "git config " ++ key ++ " " ++ value 		]-	`describe` ("git repo at " ++ repo-		 ++ " config setting " ++ key ++ " set to " ++ value)+		`assume` MadeChange+		`describe` desc+  where+	alreadyconfigured = do+		vs <- getRepoConfig repo key+		return $ value `elem` vs+	desc = "git repo at " ++ repo  ++ " config setting " ++ key ++ " set to " ++ value++-- | Gets the value that a key is set to in a git repo's configuration.+getRepoConfig :: FilePath -> String -> IO [String]+getRepoConfig repo key = catchDefaultIO [] $+	lines <$> readProcess "git" ["-C", repo, "config", key]  -- | Whether a repo accepts non-fast-forward pushes. repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo

@@ -5,7 +5,7 @@ type GID = Int  exists :: Group -> Maybe GID -> Property NoInfo-exists (Group group') mgid = check test (cmdProperty "addgroup" $ args mgid)+exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid)) 	`describe` unwords ["group", group']   where 	groupFile = "/etc/group"

@@ -20,13 +20,13 @@ -- -- This includes running update-grub. installed :: BIOS -> Property NoInfo-installed bios = installed' bios `before` mkConfig+installed bios = installed' bios `onChange` mkConfig  -- Run update-grub, to generate the grub boot menu. It will be--- automatically updated when kernel packages are---   -- installed.+-- automatically updated when kernel packages are installed. mkConfig :: Property NoInfo mkConfig = cmdProperty "update-grub" []+	`assume` MadeChange  -- | Installs grub; does not run update-grub. installed' :: BIOS -> Property NoInfo@@ -50,6 +50,7 @@ -- onChange after OS.cleanInstallOnce. boots :: OSDevice -> Property NoInfo boots dev = cmdProperty "grub-install" [dev]+	`assume` MadeChange 	`describe` ("grub boots " ++ dev)  -- | Use PV-grub chaining to boot@@ -75,8 +76,9 @@ 	, "/boot/load.cf" `File.hasContent` 		[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ] 	, installed Xen-	, flagFile (scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim"-			`describe` "/boot-xen-shim"+	, flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]+		`assume` MadeChange+		`describe` "/boot-xen-shim" 	]   where 	desc = "chain PV-grub"

@@ -11,8 +11,8 @@ 	[ Hostname.sane 	, "worked around grub/lvm boot bug #743126" ==> 		"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"-		`onChange` cmdProperty "update-grub" []-		`onChange` cmdProperty "update-initramfs" ["-u"]+		`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)+		`onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) 	, combineProperties "nuked cloudatcost cruft" 		[ File.notPresent "/etc/rc.local" 		, File.notPresent "/etc/init.d/S97-setup.sh"

@@ -35,30 +35,33 @@ setTo = setTo' extractDomain  setTo' :: ExtractDomain -> HostName -> Property NoInfo-setTo' extractdomain hn = combineProperties desc go+setTo' extractdomain hn = combineProperties desc+	[ "/etc/hostname" `File.hasContent` [basehost]+	, hostslines $ catMaybes+		[ if null domain+			then Nothing +			else Just ("127.0.1.1", [hn, basehost])+		, Just ("127.0.0.1", ["localhost"])+		]+	, check (not <$> inChroot) $+		cmdProperty "hostname" [basehost]+			`assume` NoChange+	, "/etc/mailname" `File.hasContent`+		[if null domain then hn else domain]+	]   where 	desc = "hostname " ++ hn 	basehost = takeWhile (/= '.') hn 	domain = extractdomain hn--	go = catMaybes-		[ Just $ "/etc/hostname" `File.hasContent` [basehost]-		, if null domain-			then Nothing -			else Just $ trivial $ hostsline "127.0.1.1" [hn, basehost]-		, Just $ trivial $ hostsline "127.0.0.1" ["localhost"]-		, Just $ trivial $ check (not <$> inChroot) $-			cmdProperty "hostname" [basehost]-		, Just $ "/etc/mailname" `File.hasContent`-			[if null domain then hn else domain]-		] 	-	hostsline ip names = File.fileProperty desc-		(addhostsline ip names)-		"/etc/hosts"-	addhostsline ip names ls =-		(ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls-	hasip ip l = headMaybe (words l) == Just ip+	hostslines ipsnames = +		File.fileProperty desc (addhostslines ipsnames) "/etc/hosts"+	addhostslines :: [(String, [String])] -> [String] -> [String]+	addhostslines ipsnames ls =+		let ips = map fst ipsnames+		    hasip l = maybe False (`elem` ips) (headMaybe (words l))+		    mkline (ip, names) = ip ++ "\t" ++ (unwords names)+		in map mkline ipsnames ++ filter (not . hasip) ls  -- | Makes </etc/resolv.conf> contain search and domain lines for  -- the domain that the hostname is in.

@@ -17,7 +17,8 @@ configuredSize :: Systemd.Option -> DataSize -> Property NoInfo configuredSize option s = case readSize dataUnits s of 	Just sz -> configured option (systemdSizeUnits sz)-	Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange+	Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $+		return FailedChange  systemMaxUse :: DataSize -> Property NoInfo systemMaxUse = configuredSize "SystemMaxUse"

@@ -0,0 +1,80 @@+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>++module Propellor.Property.Locale where++import Propellor.Base+import Propellor.Property.File++import Data.List (isPrefixOf)++type Locale = String+type LocaleVariable = String++-- | Select a locale for a list of global locale variables.+--+-- A locale variable is of the form @LC_BLAH@, @LANG@ or @LANGUAGE@.  See+-- @locale(5)@.  One might say+--+--  >  & "en_GB.UTF-8" `Locale.selectedFor` ["LC_PAPER", "LC_MONETARY"]+--+-- to select the British English locale for paper size and currency conventions.+--+-- Note that reverting this property does not make a locale unavailable.  That's+-- because it might be required for other Locale.selectedFor statements.+selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo+locale `selectedFor` vars = select <!> deselect+  where+	select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs)+		`requires` available locale+		`describe` (locale ++ " locale selected")+	deselect = check isselected (cmdProperty "update-locale" vars)+		`describe` (locale ++ " locale deselected")+	selectArgs = zipWith (++) vars (repeat ('=':locale))+	isselected = locale `isSelectedFor` vars++isSelectedFor :: Locale -> [LocaleVariable] -> IO Bool+locale `isSelectedFor` vars = do+	ls <- catchDefaultIO [] $ lines <$> readFile "/etc/default/locale"+	return $ and $ map (\v -> v ++ "=" ++ locale `elem` ls) vars+	++-- | Ensures a locale is generated (or, if reverted, ensure it's not).+--+-- Fails if a locale is not available to be generated.  That is, a commented out+-- entry for the locale and an accompanying charset must be present in+-- /etc/locale.gen.+--+-- Per Debian bug #684134 we cannot ensure a locale is generated by means of+-- Apt.reConfigure.  So localeAvailable edits /etc/locale.gen manually.+available :: Locale -> RevertableProperty NoInfo+available locale = (ensureAvailable <!> ensureUnavailable)+  where+	f = "/etc/locale.gen"+	desc = (locale ++ " locale generated")+	ensureAvailable =+		property desc $ (lines <$> (liftIO $ readFile f))+			>>= \locales ->+					if locale `presentIn` locales+					then ensureProperty $+						fileProperty desc (foldr uncomment []) f+						`onChange` regenerate+					else return FailedChange -- locale unavailable for generation+	ensureUnavailable =+		fileProperty (locale ++ " locale not generated") (foldr comment []) f+		`onChange` regenerate++	uncomment l ls =+		if ("# " ++ locale) `isPrefixOf` l+		then drop 2 l : ls+		else l:ls+	comment l ls =+		if locale `isPrefixOf` l+		then ("# " ++ l) : ls+		else l:ls++	l `presentIn` ls = any (l `isPrefix`) ls+	l `isPrefix` x = (l `isPrefixOf` x) || (("# " ++ l) `isPrefixOf` x)++	regenerate = cmdProperty "dpkg-reconfigure"+		["-f", "noninteractive", "locales"]+		`assume` MadeChange

@@ -45,6 +45,7 @@ -- in the second directory. bindMount :: FilePath -> FilePath -> Property NoInfo bindMount src dest = cmdProperty "mount" ["--bind", src, dest]+	`assume` MadeChange 	`describe` ("bind mounted " ++ src ++ " to " ++ dest)  mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool

@@ -7,6 +7,7 @@  ifUp :: Interface -> Property NoInfo ifUp iface = cmdProperty "ifup" [iface]+	`assume` MadeChange  -- | Resets /etc/network/interfaces to a clean and empty state, -- containing just the standard loopback interface, and with

@@ -17,7 +17,7 @@ 		`requires` siteAvailable hn cf 		`requires` installed 		`onChange` reloaded-	disable = trivial $ File.notPresent (siteVal hn)+	disable = File.notPresent (siteVal hn) 		`describe` ("nginx site disable" ++ hn) 		`requires` installed 		`onChange` reloaded

@@ -194,9 +194,10 @@ -- Parted is run in script mode, so it will never prompt for input. -- It is asked to use cylinder alignment for the disk. parted :: Eep -> FilePath -> [String] -> Property NoInfo-parted YesReallyDeleteDiskContents disk ps = -	cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)-		`requires` installed+parted YesReallyDeleteDiskContents disk ps = p `requires` installed+  where+	p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)+		`assume` MadeChange  -- | Gets parted installed. installed :: Property NoInfo

@@ -25,8 +25,9 @@ type MkfsOpts = [String]  formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo-formatted' opts YesReallyFormatPartition fs dev = -	cmdProperty cmd opts' `requires` Apt.installed [pkg]+formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts'+	`assume` MadeChange+	`requires` Apt.installed [pkg]   where 	(cmd, opts', pkg) = case fs of 		EXT2 -> ("mkfs.ext2", q $ eff optsdev, "e2fsprogs")

@@ -32,7 +32,7 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup 	`requires` installed   where-	setup = trivial $ property "postfix satellite system" $ do+	setup = property "postfix satellite system" $ do 		hn <- asks hostName 		let (_, domain) = separate (== '.') hn 		ensureProperties@@ -55,12 +55,13 @@ 	-> (FilePath -> Property x) 	-> Property (CInfo x NoInfo) mappedFile f setup = setup f-	`onChange` cmdProperty "postmap" [f]+	`onChange` (cmdProperty "postmap" [f] `assume` MadeChange)  -- | Run newaliases command, which should be done after changing -- @/etc/aliases@. newaliases :: Property NoInfo-newaliases = trivial $ cmdProperty "newaliases" []+newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")+	(cmdProperty "newaliases" [])  -- | The main config file for postfix. mainCfFile :: FilePath@@ -134,6 +135,11 @@ -- Does not configure postfix to use it; eg @smtpd_sasl_auth_enable = yes@ -- needs to be set to enable use. See -- <https://wiki.debian.org/PostfixAndSASL>.+--+-- Password brute force attacks are possible when SASL auth is enabled.+-- It would be wise to enable fail2ban, for example:+--+-- > Fail2Ban.jailEnabled "postfix-sasl" saslAuthdInstalled :: Property NoInfo saslAuthdInstalled = setupdaemon 	`requires` Service.running "saslauthd"@@ -157,3 +163,22 @@ 	postfixgroup = (User "postfix") `User.hasGroup` (Group "sasl") 		`onChange` restarted 	dir = "/var/spool/postfix/var/run/saslauthd"++-- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file.+--+-- The password is taken from the privdata.+saslPasswdSet :: Domain -> User -> Property HasInfo+saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"+  where+	go = withPrivData src ctx $ \getpw ->+		property desc $ getpw $ \pw -> liftIO $+			withHandle StdinHandle createProcessSuccess p $ \h -> do+				hPutStrLn h (privDataVal pw)+				hClose h+				return NoChange+	desc = "sasl password for " ++ uatd+	uatd = user ++ "@" ++ domain+	ps = ["-p", "-c", "-u", domain, user]+	p = proc "saslpasswd2" ps+	ctx = Context "sasl"+	src = PrivDataSource (Password uatd) "enter password"

@@ -24,7 +24,7 @@ 		dir = confValPath conf 		confValRelativePath conf' = File.LinkTarget $ 			"../conf.avail" </> conf' <.> "cfg.lua"-	disable = trivial $ File.notPresent (confValPath conf)+	disable = File.notPresent (confValPath conf) 		`describe` ("prosody conf disabled " ++ conf) 		`requires` installed 		`onChange` reloaded

@@ -4,6 +4,7 @@  now :: Property NoInfo now = cmdProperty "reboot" []+	`assume` MadeChange 	`describe` "reboot now"  -- | Schedules a reboot at the end of the current propellor run.

@@ -58,4 +58,5 @@  rsync :: [String] -> Property NoInfo rsync ps = cmdProperty "rsync" ps+	`assume` MadeChange 	`requires` Apt.installed ["rsync"]

@@ -21,7 +21,7 @@ reloaded = signaled "reload" "reloaded"  signaled :: String -> Desc -> ServiceName -> Property NoInfo-signaled cmd desc svc = property (desc ++ " " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]-	return NoChange+signaled cmd desc svc = p `describe` (desc ++ " " ++ svc)+  where+	p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]+		`assume` NoChange

@@ -17,7 +17,7 @@ 		, "en_US.UTF-8 UTF-8" 		, "fi_FI.UTF-8 UTF-8" 		]-		`onChange` cmdProperty "locale-gen" []+		`onChange` (cmdProperty "locale-gen" [] `assume` MadeChange)  	& Apt.installed ["etckeeper", "ssh", "popularity-contest"] 	& Apt.serviceInstalledRunning "apache2"

@@ -60,6 +60,7 @@ 			, "cd " ++ gitbuilderdir 			, "git checkout " ++ buildarch ++ fromMaybe "" flavor 			]+			`assume` MadeChange 			`describe` "gitbuilder setup" 	builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty (User builduser) 		[ "git clone git://git-annex.branchable.com/ " ++ builddir@@ -88,13 +89,16 @@ 	go = userScriptProperty (User builduser) 		[ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages" 		]+		`assume` MadeChange  -- Installs current versions of git-annex's deps from cabal, but only -- does so once. cabalDeps :: Property NoInfo cabalDeps = flagFile go cabalupdated 	where-		go = userScriptProperty (User builduser) ["cabal update && cabal install git-annex --only-dependencies || true"]+		go = userScriptProperty (User builduser)+			["cabal update && cabal install git-annex --only-dependencies || true"]+			`assume` MadeChange 		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"  autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container@@ -158,5 +162,6 @@ 	chrootsetup = scriptProperty 		[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" 		]+		`assume` MadeChange 	osver = System (Debian (Stable "jessie")) "i386" 	bootstrap = Chroot.debootstrapped mempty

@@ -14,11 +14,13 @@ 		let tmpdir = home </> "githome" 		ensureProperty $ combineProperties "githome setup" 			[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]+				`assume` MadeChange 			, property "moveout" $ makeChange $ void $ 				moveout tmpdir home 			, property "rmdir" $ makeChange $ void $ 				catchMaybeIO $ removeDirectory tmpdir 			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]+				`assume` MadeChange 			] 	moveout tmpdir home = do 		fs <- dirContents tmpdir

@@ -30,7 +30,7 @@ 	& Ssh.knownHost knownhosts "gitlab.com" (User "root") 	& Git.cloned (User "root") userrepo "/usr/local/IA.BAK/pubkeys" (Just "master") 	& Apt.serviceInstalledRunning "apache2"-	& cmdProperty "ln" ["-sf", "/usr/local/IA.BAK/pushme.cgi", "/usr/lib/cgi-bin/pushme.cgi"]+	& "/usr/lib/cgi-bin/pushme.cgi" `File.isSymlinkedTo` File.LinkTarget "/usr/local/IA.BAK/pushme.cgi" 	& File.containsLine "/etc/sudoers" "www-data ALL=NOPASSWD:/usr/local/IA.BAK/pushed.sh" 	& Cron.niceJob "shardstats" (Cron.Times "*/30 * * * *") (User "root") "/" 		"/usr/local/IA.BAK/shardstats-all"@@ -51,8 +51,9 @@ 	& Git.cloned (User "registrar") userrepo "/home/registrar/users" (Just "master") 	& Apt.serviceInstalledRunning "apache2" 	& Apt.installed ["perl", "perl-modules"]-	& cmdProperty "ln" ["-sf", "/home/registrar/IA.BAK/registrar/register.cgi", link]+	& link `File.isSymlinkedTo` File.LinkTarget "/home/registrar/IA.BAK/registrar/register.cgi" 	& cmdProperty "chown" ["-h", "registrar:registrar", link]+		`changesFile` link 	& File.containsLine "/etc/sudoers" "www-data ALL=(registrar) NOPASSWD:/home/registrar/IA.BAK/registrar/register.pl" 	& Apt.installed ["kgb-client"] 	& File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext@@ -84,11 +85,15 @@ 		, "retentions = 60s:1d" 		] 	& graphiteCSRF-	& cmdProperty "graphite-manage" ["syncdb", "--noinput"] `flagFile` "/etc/flagFiles/graphite-syncdb"-	& cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=joey", "--email=joey@localhost"] `flagFile` "/etc/flagFiles/graphite-user-joey"-		`flagFile` "/etc/graphite-superuser-joey"-	& cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=db48x", "--email=db48x@localhost"] `flagFile` "/etc/flagFiles/graphite-user-db48x"-		`flagFile` "/etc/graphite-superuser-db48x"+	& cmdProperty "graphite-manage" ["syncdb", "--noinput"]+		`assume` MadeChange+		`flagFile` "/etc/flagFiles/graphite-syncdb"+	& cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=joey", "--email=joey@localhost"]+		`assume` MadeChange+		`flagFile` "/etc/flagFiles/graphite-user-joey"+	& cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=db48x", "--email=db48x@localhost"]+		`assume` MadeChange+		`flagFile` "/etc/flagFiles/graphite-user-db48x" 	-- TODO: deal with passwords somehow 	& File.ownerGroup "/var/lib/graphite/graphite.db" (User "_graphite") (Group "_graphite") 	& "/etc/apache2/ports.conf" `File.containsLine` "Listen 8080"

@@ -17,6 +17,7 @@ import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Systemd as Systemd+import qualified Propellor.Property.Fail2Ban as Fail2Ban import Utility.FileMode  import Data.List@@ -38,6 +39,7 @@ 		, "cabal configure" 		, "make" 		]+		`assume` MadeChange 	& s `File.hasContent` 		[ "#!/bin/sh" 		, "set -e"@@ -164,7 +166,9 @@ 			, "dpkg -i ../" ++ pkg ++ "_*.deb || true" 			, "apt-get -fy install" -- dependencies 			, "rm -rf /root/tmp/oldusenet"-			] `describe` "olduse.net built"+			]+			`assume` MadeChange+			`describe` "olduse.net built"  kgbServer :: Property HasInfo kgbServer = propertyList desc $ props@@ -196,7 +200,8 @@  			(Context hn) 			(SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDSXXSM3mM8SNu+qel9R/LkDIkjpV3bfpUtRtYv2PTNqicHP+DdoThrr0ColFCtLH+k2vQJvR2n8uMzHn53Dq2IO3TtD27+7rJSsJwAZ8oftNzuTir8IjAwX5g6JYJs+L0Ny4RB0ausd+An0k/CPMRl79zKxpZd2MBMDNXt8hyqu0vS0v1ohq5VBEVhBBvRvmNQvWOCj7PdrKQXpUBHruZOeVVEdUUXZkVc1H0t7LVfJnE+nGKyWbw2jM+7r3Rn5Semc4R1DxsfaF8lKkZyE88/5uZQ/ddomv8ptz6YZ5b+Bg6wfooWPC3RWAALjxnHaC2yN1VONAvHmT0uNn1o6v0b") 		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root")-	& trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"])+	& cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]+		`assume` NoChange   where 	hn = "mumble.debian.net" 	sshkey = "/root/.ssh/mumble.debian.net.key"@@ -273,6 +278,7 @@ 	dir = "/srv/web/" ++ hn 	postupdatehook = dir </> ".git/hooks/post-update" 	setup = userScriptProperty (User "joey") setupscript+		`assume` MadeChange 	setupscript =  		[ "cd " ++ shellEscape dir 		, "git annex reinit " ++ shellEscape uuid@@ -392,6 +398,7 @@ 		[ "cd " ++ dir 		, "ghc --make twitRss"  		]+		`assume` NoChange 		`requires` Apt.installed 			[ "libghc-xml-dev" 			, "libghc-feed-dev"@@ -412,7 +419,8 @@ 	& File.ownerGroup conf (User "znc") (Group "znc") 	& Cron.job "znconboot" (Cron.Times "@reboot") (User "znc") "~" "znc" 	-- ensure running if it was not already-	& trivial (userScriptProperty (User "znc") ["znc || true"])+	& userScriptProperty (User "znc") ["znc || true"]+		`assume` NoChange 		`describe` "znc running"   where 	conf = "/home/znc/.znc/configs/znc.conf"@@ -541,6 +549,10 @@ 	& dkimInstalled  	& Postfix.saslAuthdInstalled+	& Fail2Ban.installed+	& Fail2Ban.jailEnabled "postfix-sasl"+	& "/etc/default/saslauthd" `File.containsLine` "MECHANISMS=sasldb"+	& Postfix.saslPasswdSet "kitenet.net" (User "errol")  	& Apt.installed ["maildrop"] 	& "/etc/maildroprc" `File.hasContent`

@@ -143,8 +143,8 @@ 			[ Param "-c" 			, Param "rm -f /etc/ssh/ssh_host_*" 			]-		ensureProperty $ scriptProperty -			[ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]+		ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]+			`assume` MadeChange  -- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI" type PubKeyText = String

@@ -71,12 +71,14 @@ -- Note that this does not configure systemd to start the service on boot, -- it only ensures that the service is currently running. started :: ServiceName -> Property NoInfo-started n = trivial $ cmdProperty "systemctl" ["start", n]+started n = cmdProperty "systemctl" ["start", n]+	`assume` NoChange 	`describe` ("service " ++ n ++ " started")  -- | Stops a systemd service. stopped :: ServiceName -> Property NoInfo-stopped n = trivial $ cmdProperty "systemctl" ["stop", n]+stopped n = cmdProperty "systemctl" ["stop", n]+	`assume` NoChange 	`describe` ("service " ++ n ++ " stopped")  -- | Enables a systemd service.@@ -84,30 +86,35 @@ -- This does not ensure the service is started, it only configures systemd -- to start it on boot. enabled :: ServiceName -> Property NoInfo-enabled n = trivial $ cmdProperty "systemctl" ["enable", n]+enabled n = cmdProperty "systemctl" ["enable", n]+	`assume` NoChange 	`describe` ("service " ++ n ++ " enabled")  -- | Disables a systemd service. disabled :: ServiceName -> Property NoInfo-disabled n = trivial $ cmdProperty "systemctl" ["disable", n]+disabled n = cmdProperty "systemctl" ["disable", n]+	`assume` NoChange 	`describe` ("service " ++ n ++ " disabled")  -- | Masks a systemd service. masked :: ServiceName -> RevertableProperty NoInfo masked n = systemdMask <!> systemdUnmask   where-	systemdMask   = trivial $ cmdProperty "systemctl" ["mask", n]-	                `describe` ("service " ++ n ++ " masked")-	systemdUnmask = trivial $ cmdProperty "systemctl" ["unmask", n]-	                `describe` ("service " ++ n ++ " unmasked")+	systemdMask = cmdProperty "systemctl" ["mask", n]+		`assume` NoChange+		`describe` ("service " ++ n ++ " masked")+	systemdUnmask = cmdProperty "systemctl" ["unmask", n]+		`assume` NoChange+		`describe` ("service " ++ n ++ " unmasked")  -- | Ensures that a service is both enabled and started running :: ServiceName -> Property NoInfo-running n = trivial $ started n `requires` enabled n+running n = started n `requires` enabled n  -- | Restarts a systemd service. restarted :: ServiceName -> Property NoInfo-restarted n = trivial $ cmdProperty "systemctl" ["restart", n]+restarted n = cmdProperty "systemctl" ["restart", n]+	`assume` NoChange 	`describe` ("service " ++ n ++ " restarted")  -- | The systemd-networkd service.@@ -123,7 +130,9 @@ persistentJournal = check (not <$> doesDirectoryExist dir) $  	combineProperties "persistent systemd journal" 		[ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]+			`assume` MadeChange 		, cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir]+			`assume` MadeChange 		, started "systemd-journal-flush" 		] 		`requires` Apt.installed ["acl"]@@ -149,12 +158,13 @@ 	line = setting ++ value 	desc = cfgfile ++ " " ++ line 	removeother l-		| setting `isPrefixOf` l = Nothing+		| setting `isPrefixOf` l && l /= line = Nothing 		| otherwise = Just l  -- | Causes systemd to reload its configuration files. daemonReloaded :: Property NoInfo-daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]+daemonReloaded = cmdProperty "systemctl" ["daemon-reload"]+	`assume` NoChange  -- | Configures journald, restarting it so the changes take effect. journaldConfigured :: Option -> String -> Property NoInfo

@@ -8,20 +8,26 @@ data Eep = YesReallyDeleteHome  accountFor :: User -> Property NoInfo-accountFor user@(User u) = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"-	[ "--disabled-password"-	, "--gecos", ""-	, u-	]+accountFor user@(User u) = check nohomedir go 	`describe` ("account for " ++ u)+  where+	nohomedir = isNothing <$> catchMaybeIO (homedir user)+	go = cmdProperty "adduser"+		[ "--disabled-password"+		, "--gecos", ""+		, u+		]  -- | Removes user home directory!! Use with caution. nuked :: User -> Eep -> Property NoInfo-nuked user@(User u) _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel"-	[ "-r"-	, u-	]+nuked user@(User u) _ = check hashomedir go 	`describe` ("nuked user " ++ u)+  where+	hashomedir = isJust <$> catchMaybeIO (homedir user)+	go = cmdProperty "userdel"+		[ "-r"+		, u+		]  -- | Only ensures that the user has some password set. It may or may -- not be a password from the PrivData.@@ -75,11 +81,13 @@ 		hClose h  lockedPassword :: User -> Property NoInfo-lockedPassword user@(User u) = check (not <$> isLockedPassword user) $ cmdProperty "passwd"-	[ "--lock"-	, u-	]+lockedPassword user@(User u) = check (not <$> isLockedPassword user) go 	`describe` ("locked " ++ u ++ " password")+  where+	go = cmdProperty "passwd"+		[ "--lock"+		, u+		]  data PasswordStatus = NoPassword | LockedPassword | HasPassword 	deriving (Eq)@@ -99,19 +107,26 @@ homedir (User user) = homeDirectory <$> getUserEntryForName user  hasGroup :: User -> Group -> Property NoInfo-hasGroup (User user) (Group group') = check test $ cmdProperty "adduser"-	[ user-	, group'-	]+hasGroup (User user) (Group group') = check test go 	`describe` unwords ["user", user, "in group", group']   where 	test = not . elem group' . words <$> readProcess "groups" [user]+	go = cmdProperty "adduser"+		[ user+		, group'+		]  -- | Gives a user access to the secondary groups, including audio and -- video, that the OS installer normally gives a desktop user access to.+--+-- Note that some groups may only exit after installation of other+-- software. When a group does not exist yet, the user won't be added to it. hasDesktopGroups :: User -> Property NoInfo-hasDesktopGroups user@(User u) = combineProperties desc $ -	map (hasGroup user . Group) desktopgroups+hasDesktopGroups user@(User u) = property desc $ do+	existinggroups <- map (fst . break (== ':')) . lines+		<$> liftIO (readFile "/etc/group")+	let toadd = filter (`elem` existinggroups) desktopgroups+	ensureProperty $ propertyList desc $ map (hasGroup user . Group) toadd   where 	desc = "user " ++ u ++ " is in standard desktop groups" 	-- This list comes from user-setup's debconf@@ -132,11 +147,11 @@  -- | Controls whether shadow passwords are enabled or not. shadowConfig :: Bool -> Property NoInfo-shadowConfig True = check (not <$> shadowExists) $-	cmdProperty "shadowconfig" ["on"]+shadowConfig True = check (not <$> shadowExists)+	(cmdProperty "shadowconfig" ["on"]) 		`describe` "shadow passwords enabled"-shadowConfig False = check shadowExists $-	cmdProperty "shadowconfig" ["off"]+shadowConfig False = check shadowExists+	(cmdProperty "shadowconfig" ["off"]) 		`describe` "shadow passwords disabled"  shadowExists :: IO Bool@@ -148,8 +163,8 @@ hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell  shellSetTo :: User -> FilePath -> Property NoInfo-shellSetTo (User u) loginshell = check needchangeshell $-	cmdProperty "chsh" ["--shell", loginshell, u]+shellSetTo (User u) loginshell = check needchangeshell+	(cmdProperty "chsh" ["--shell", loginshell, u]) 		`describe` (u ++ " has login shell " ++ loginshell)   where 	needchangeshell = do

@@ -19,7 +19,7 @@ 		`requires` appAvailable an cf 		`requires` installed 		`onChange` reloaded-	disable = trivial $ File.notPresent (appVal an)+	disable = File.notPresent (appVal an) 		`describe` ("uwsgi app disable" ++ an) 		`requires` installed 		`onChange` reloaded

@@ -0,0 +1,82 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Propellor.Types.ResultCheck (+	UncheckedProperty,+	unchecked,+	checkResult,+	check,+	Checkable,+	assume,+) where++import Propellor.Types+import Propellor.Exception+import Utility.Monad++import Data.Monoid++-- | This is a `Property` but its `Result` is not accurate; in particular+-- it may return `NoChange` despite having made a change. +--+-- However, when it returns `MadeChange`, it really did make a change,+-- and `FailedChange` is still an error.+data UncheckedProperty i = UncheckedProperty (Property i)++-- | Use to indicate that a Property is unchecked.+unchecked :: Property i -> UncheckedProperty i+unchecked = UncheckedProperty++-- | Checks the result of a property. Mostly used to convert a+-- `UncheckedProperty` to a `Property`, but can also be used to further+-- check a `Property`.+checkResult +	:: (Checkable p i, LiftPropellor m)+	=> m a+	-- ^ Run before ensuring the property.+	-> (a -> m Result)+	-- ^ Run after ensuring the property. Return `MadeChange` if a+	-- change was detected, or `NoChange` if no change was detected.+	-> p i+	-> Property i+checkResult precheck postcheck p = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do+	a <- liftPropellor precheck+	r <- catchPropellor satisfy+	-- Always run postcheck, even if the result is already MadeChange,+	-- as it may need to clean up after precheck.+	r' <- liftPropellor $ postcheck a+	return (r <> r')++-- | Makes a `Property` or an `UncheckedProperty` only run+-- when a test succeeds.+check :: (Checkable p i, LiftPropellor m) => m Bool -> p i -> Property i+check test p = adjustPropertySatisfy (preCheckedProp p) $ \satisfy ->+        ifM (liftPropellor test)+                ( satisfy+                , return NoChange+                )++class Checkable p i where+	checkedProp :: p i -> Property i+	preCheckedProp :: p i -> Property i++instance Checkable Property i where+	checkedProp = id+	preCheckedProp = id++instance Checkable UncheckedProperty i where+	checkedProp (UncheckedProperty p) = p+	-- Since it was pre-checked that the property needed to be run,+	-- if the property succeeded, we can assume it made a change.+	preCheckedProp (UncheckedProperty p) = p `assume` MadeChange++-- | Sometimes it's not practical to test if a property made a change.+-- In such a case, it's often fine to say:+--+-- > someprop `assume` MadeChange+--+-- However, beware assuming `NoChange`, as that will make combinators+-- like `onChange` not work.+assume :: Checkable p i => p i -> Result -> Property i+assume p result = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do+	r <- satisfy+	return (r <> result)