summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog21
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Property.hs1
-rw-r--r--src/Propellor/Property/Apache.hs5
-rw-r--r--src/Propellor/Property/Apt.hs38
-rw-r--r--src/Propellor/Property/Chroot.hs1
-rw-r--r--src/Propellor/Property/Cmd.hs27
-rw-r--r--src/Propellor/Property/DebianMirror.hs6
-rw-r--r--src/Propellor/Property/DiskImage.hs6
-rw-r--r--src/Propellor/Property/Docker.hs11
-rw-r--r--src/Propellor/Property/File.hs16
-rw-r--r--src/Propellor/Property/Git.hs47
-rw-r--r--src/Propellor/Property/Group.hs6
-rw-r--r--src/Propellor/Property/Grub.hs7
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs4
-rw-r--r--src/Propellor/Property/Hostname.hs7
-rw-r--r--src/Propellor/Property/Locale.hs12
-rw-r--r--src/Propellor/Property/Mount.hs1
-rw-r--r--src/Propellor/Property/Network.hs1
-rw-r--r--src/Propellor/Property/Parted.hs7
-rw-r--r--src/Propellor/Property/Partition.hs5
-rw-r--r--src/Propellor/Property/Postfix.hs7
-rw-r--r--src/Propellor/Property/Reboot.hs1
-rw-r--r--src/Propellor/Property/Rsync.hs1
-rw-r--r--src/Propellor/Property/Service.hs8
-rw-r--r--src/Propellor/Property/SiteSpecific/Branchable.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs8
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/IABak.hs19
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs13
-rw-r--r--src/Propellor/Property/Ssh.hs4
-rw-r--r--src/Propellor/Property/Systemd.hs32
-rw-r--r--src/Propellor/Property/User.hs57
-rw-r--r--src/Propellor/Types/ResultCheck.hs13
34 files changed, 270 insertions, 128 deletions
diff --git a/debian/changelog b/debian/changelog
index 2290ccc5..1da30f22 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,14 +1,27 @@
-propellor (2.14.1) UNRELEASED; urgency=medium
+propellor (2.15.0) UNRELEASED; 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
+ * 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.
- * Added UncheckedProperty type, along with unchecked to indicate a
- Property needs its result checked, and checkResult and changesFile
- to check for changes.
-- Joey Hess <id@joeyh.name> Tue, 24 Nov 2015 17:06:12 -0400
diff --git a/propellor.cabal b/propellor.cabal
index b59e35dd..a019afe8 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -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>
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index f57fcaee..c57ef2f0 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -31,6 +31,7 @@ module Propellor.Property (
, changesFile
, checkResult
, Checkable
+ , assume
) where
import System.Directory
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index c2f49cff..626d3879 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -39,6 +39,7 @@ siteEnabled hn cf = enable <!> disable
`onChange` reloaded
, check (not <$> isenabled) $
cmdProperty "a2ensite" ["--quiet", hn]
+ `assume` MadeChange
`requires` installed
`onChange` reloaded
]
@@ -49,7 +50,7 @@ siteDisabled :: HostName -> Property NoInfo
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
@@ -64,11 +65,13 @@ modEnabled modname = enable <!> disable
where
enable = check (not <$> isenabled) $
cmdProperty "a2enmod" ["--quiet", modname]
+ `assume` MadeChange
`describe` ("apache module enabled " ++ modname)
`requires` installed
`onChange` reloaded
disable = check isenabled $
cmdProperty "a2dismod" ["--quiet", modname]
+ `assume` MadeChange
`describe` ("apache module disabled " ++ modname)
`requires` installed
`onChange` reloaded
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 83ad2cda..cf81c9be 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -108,7 +108,7 @@ setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
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 @@ noninteractiveEnv =
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,17 @@ installed' :: [String] -> [Package] -> Property NoInfo
installed' params ps = robustly $ check (isInstallable ps) go
`describe` (unwords $ "apt installed":ps)
where
- go = runApt $ params ++ ["install"] ++ ps
+ go = runApt (params ++ ["install"] ++ ps)
+ `assume` MadeChange
installedBackport :: [Package] -> Property NoInfo
installedBackport ps = trivial $ 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)
+ `assume` MadeChange
_ -> notsupported o
where
desc = (unwords $ "apt installed backport":ps)
@@ -156,11 +160,11 @@ removed :: [Package] -> Property NoInfo
removed ps = check (or <$> isInstalled' ps) go
`describe` (unwords $ "apt removed":ps)
where
- go = runApt $ ["-y", "remove"] ++ ps
+ go = runApt (["-y", "remove"] ++ ps) `assume` MadeChange
buildDep :: [Package] -> Property NoInfo
-buildDep ps = trivial (robustly go)
- `changesFile` "/var/lib/dpkg/status"
+buildDep ps = robustly $ go
+ `changesFile` dpkgStatus
`describe` (unwords $ "apt build-dep":ps)
where
go = runApt $ ["-y", "build-dep"] ++ ps
@@ -169,10 +173,11 @@ buildDep ps = trivial (robustly go)
-- 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.
@@ -210,6 +215,7 @@ isInstalled' ps = (mapMaybe parse . lines) <$> policy
autoRemove :: Property NoInfo
autoRemove = runApt ["-y", "autoremove"]
+ `changesFile` dpkgStatus
`describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable.
@@ -260,6 +266,7 @@ reConfigure package vals = reconfigure `requires` setselections
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.
--
@@ -296,13 +303,18 @@ aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-- | 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` MadeChange
`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"
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 30c11ed3..cfa70e9f 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -74,6 +74,7 @@ extractTarball :: FilePath -> FilePath -> Property HasInfo
extractTarball target src = toProp .
check (unpopulated target) $
cmdProperty "tar" params
+ `assume` MadeChange
`requires` File.dirExists target
where
params =
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 9536f71d..b02376a3 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -32,22 +32,31 @@ import Utility.Process (createProcess, CreateProcess, waitForProcess)
-- | A property that can be satisfied by running a command.
--
-- The command must exit 0 on success.
-cmdProperty :: String -> [String] -> Property NoInfo
+--
+-- This and other properties in this module are `UncheckedProperty`,
+-- and return `NoChange`. It's up to the user to check if the command
+-- made a change to the system, perhaps by using `checkResult` or
+-- `changesFile`, or you can use @cmdProperty "foo" ["bar"] `assume` MadeChange@
+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 +64,14 @@ cmdPropertyEnv cmd params env = property desc $ liftIO $ do
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)
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index 468cca32..14024a4e 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -126,8 +126,10 @@ mirror mirror' = propertyList
, 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
+ `assume` MadeChange
+ `describe` "debmirror setup"
, Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $
unwords ("/usr/bin/debmirror" : args)
]
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 2e0ec661..79237e61 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -287,15 +287,21 @@ grubBooted bios = (Grub.installed' bios, boots)
, 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]
+ `assume` MadeChange
, inchroot "update-grub" []
+ `assume` MadeChange
, check haveosprober $ inchroot "chmod" ["+x", osprober]
+ `assume` MadeChange
, 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
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 0cc8212b..932ba2c1 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -160,6 +160,7 @@ imageBuilt directory ctr = describe built msg
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 @@ imagePulled ctr = describe pulled msg
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 @@ garbageCollected = propertyList "docker garbage collected"
-- 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 @@ tweaked = trivial $
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++"\""
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index e29eceb8..56066b5b 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -158,19 +158,19 @@ f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
-- | 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.
--
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index d9540994..46f6abc7 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -79,18 +79,20 @@ cloned owner url dir mbranch = check originurl (property desc checkout)
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 @@ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: "
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
diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs
index ce8a8398..8499d636 100644
--- a/src/Propellor/Property/Group.hs
+++ b/src/Propellor/Property/Group.hs
@@ -5,8 +5,10 @@ import Propellor.Base
type GID = Int
exists :: Group -> Maybe GID -> Property NoInfo
-exists (Group group') mgid = check test (cmdProperty "addgroup" $ args mgid)
- `describe` unwords ["group", group']
+exists (Group group') mgid = check test $
+ cmdProperty "addgroup" (args mgid)
+ `assume` MadeChange
+ `describe` unwords ["group", group']
where
groupFile = "/etc/group"
test = not . elem group' . words <$> readProcess "cut" ["-d:", "-f1", groupFile]
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index ea54295b..024a2827 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -27,6 +27,7 @@ installed bios = installed' bios `before` mkConfig
-- -- installed.
mkConfig :: Property NoInfo
mkConfig = cmdProperty "update-grub" []
+ `assume` MadeChange
-- | Installs grub; does not run update-grub.
installed' :: BIOS -> Property NoInfo
@@ -50,6 +51,7 @@ installed' bios = Apt.installed [pkg] `describe` "grub package installed"
-- 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 +77,9 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc
, "/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"
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index 6097c642..ef7dd743 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -11,8 +11,8 @@ decruft = propertyList "cloudatcost cleanup"
[ 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"
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 4597b178..fcb88f59 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -45,10 +45,11 @@ setTo' extractdomain hn = combineProperties desc go
[ 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) $
+ else Just $ hostsline "127.0.1.1" [hn, basehost]
+ , Just $ hostsline "127.0.0.1" ["localhost"]
+ , Just $ check (not <$> inChroot) $
cmdProperty "hostname" [basehost]
+ `assume` NoChange
, Just $ "/etc/mailname" `File.hasContent`
[if null domain then hn else domain]
]
diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs
index c1040780..0342a2f2 100644
--- a/src/Propellor/Property/Locale.hs
+++ b/src/Propellor/Property/Locale.hs
@@ -24,12 +24,12 @@ type LocaleVariable = String
selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo
locale `selectedFor` vars = select <!> deselect
where
- select =
- trivial $ cmdProperty "update-locale" selectArgs
+ select = cmdProperty "update-locale" selectArgs
+ `assume` NoChange
`requires` available locale
`describe` (locale ++ " locale selected")
- deselect =
- trivial $ cmdProperty "update-locale" vars
+ deselect = cmdProperty "update-locale" vars
+ `assume` NoChange
`describe` (locale ++ " locale deselected")
selectArgs = zipWith (++) vars (repeat ('=':locale))
@@ -70,4 +70,6 @@ available locale = (ensureAvailable <!> ensureUnavailable)
l `presentIn` ls = any (l `isPrefix`) ls
l `isPrefix` x = (l `isPrefixOf` x) || (("# " ++ l) `isPrefixOf` x)
- regenerate = cmdProperty "dpkg-reconfigure" ["-f", "noninteractive", "locales"]
+ regenerate = cmdProperty "dpkg-reconfigure"
+ ["-f", "noninteractive", "locales"]
+ `assume` MadeChange
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 3f96044e..590cede9 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -45,6 +45,7 @@ mounted fs src mnt opts = property (mnt ++ " mounted") $
-- 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
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index cb340042..1908bbb3 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -7,6 +7,7 @@ type Interface = String
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
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 834b6c7d..5d6afa9c 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -194,9 +194,10 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do
-- 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
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index d39ceea6..b2f50339 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -25,8 +25,9 @@ formatted = formatted' []
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")
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 356a945f..782e7f45 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -55,12 +55,13 @@ mappedFile
-> (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 = cmdProperty "newaliases" []
+ `assume` MadeChange
-- | The main config file for postfix.
mainCfFile :: FilePath
@@ -74,6 +75,7 @@ mainCf (name, value) = check notset set
setting = name ++ "=" ++ value
notset = (/= Just value) <$> getMainCf name
set = cmdProperty "postconf" ["-e", setting]
+ `assume` MadeChange
-- | Gets a main.cf setting.
getMainCf :: String -> IO (Maybe String)
@@ -159,6 +161,7 @@ saslAuthdInstalled = setupdaemon
dirperm = check (not <$> doesDirectoryExist dir) $
cmdProperty "dpkg-statoverride"
[ "--add", "root", "sasl", "710", dir ]
+ `assume` MadeChange
postfixgroup = (User "postfix") `User.hasGroup` (Group "sasl")
`onChange` restarted
dir = "/var/spool/postfix/var/run/saslauthd"
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index ef0182d3..26b85840 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -4,6 +4,7 @@ import Propellor.Base
now :: Property NoInfo
now = cmdProperty "reboot" []
+ `assume` MadeChange
`describe` "reboot now"
-- | Schedules a reboot at the end of the current propellor run.
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index cae3c877..0c77df58 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -58,4 +58,5 @@ syncDirFiltered filters src dest = rsync $
rsync :: [String] -> Property NoInfo
rsync ps = cmdProperty "rsync" ps
+ `assume` MadeChange
`requires` Apt.installed ["rsync"]
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index 76c9aff7..0e96ed4c 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -21,7 +21,7 @@ reloaded :: ServiceName -> Property NoInfo
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
diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs
index 66b7ed11..5c85610b 100644
--- a/src/Propellor/Property/SiteSpecific/Branchable.hs
+++ b/src/Propellor/Property/SiteSpecific/Branchable.hs
@@ -17,7 +17,7 @@ server hosts = propertyList "branchable server" $ props
, "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"
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 3f7cbad1..a34071ce 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -60,10 +60,12 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
, "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
]
+ `assume` MadeChange
buildDepsApt :: Property HasInfo
buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
@@ -88,13 +90,16 @@ haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
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 +163,6 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name osve
chrootsetup = scriptProperty
[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
]
+ `assume` MadeChange
osver = System (Debian (Stable "jessie")) "i386"
bootstrap = Chroot.debootstrapped mempty
diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs
index 9b01b5e2..83a1a16a 100644
--- a/src/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/src/Propellor/Property/SiteSpecific/GitHome.hs
@@ -14,11 +14,13 @@ installedFor user@(User u) = check (not <$> hasGitDir user) $
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
diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs
index fce5aefb..bb62fba7 100644
--- a/src/Propellor/Property/SiteSpecific/IABak.hs
+++ b/src/Propellor/Property/SiteSpecific/IABak.hs
@@ -30,7 +30,7 @@ gitServer knownhosts = propertyList "iabak git server" $ props
& 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 @@ registrationServer knownhosts = propertyList "iabak registration server" $ props
& 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 @@ graphiteServer = propertyList "iabak graphite server" $ props
, "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"
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index ff92bf2d..732714db 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -39,6 +39,7 @@ scrollBox = propertyList "scroll server" $ props
, "cabal configure"
, "make"
]
+ `assume` MadeChange
& s `File.hasContent`
[ "#!/bin/sh"
, "set -e"
@@ -165,7 +166,9 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
, "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
@@ -197,7 +200,8 @@ mumbleServer hosts = combineProperties hn $ props
(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"
@@ -274,6 +278,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
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
@@ -393,6 +398,7 @@ twitRss = combineProperties "twitter rss" $ props
[ "cd " ++ dir
, "ghc --make twitRss"
]
+ `assume` NoChange
`requires` Apt.installed
[ "libghc-xml-dev"
, "libghc-feed-dev"
@@ -413,7 +419,8 @@ ircBouncer = propertyList "IRC bouncer" $ props
& 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"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 304ed5cc..9e1fb7af 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -143,8 +143,8 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
[ 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
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 42ff8e57..04ce3b48 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -71,12 +71,14 @@ instance PropAccum Container where
-- 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 @@ stopped n = trivial $ cmdProperty "systemctl" ["stop", n]
-- 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 :: Property NoInfo
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"]
@@ -154,7 +163,8 @@ configured cfgfile option value = combineProperties desc
-- | 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
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index 564be82d..84d20e62 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -8,20 +8,28 @@ import qualified Propellor.Property.File as File
data Eep = YesReallyDeleteHome
accountFor :: User -> Property NoInfo
-accountFor user@(User u) = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
- [ "--disabled-password"
- , "--gecos", ""
- , u
- ]
- `describe` ("account for " ++ u)
+accountFor user@(User u) = check nohomedir $
+ cmdProperty "adduser"
+ [ "--disabled-password"
+ , "--gecos", ""
+ , u
+ ]
+ `assume` MadeChange
+ `describe` ("account for " ++ u)
+ where
+ nohomedir = isNothing <$> catchMaybeIO (homedir user)
-- | 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
- ]
- `describe` ("nuked user " ++ u)
+nuked user@(User u) _ = check hashomedir $
+ cmdProperty "userdel"
+ [ "-r"
+ , u
+ ]
+ `assume` MadeChange
+ `describe` ("nuked user " ++ u)
+ where
+ hashomedir = isJust <$> catchMaybeIO (homedir user)
-- | Only ensures that the user has some password set. It may or may
-- not be a password from the PrivData.
@@ -75,11 +83,13 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc
hClose h
lockedPassword :: User -> Property NoInfo
-lockedPassword user@(User u) = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
- [ "--lock"
- , u
- ]
- `describe` ("locked " ++ u ++ " password")
+lockedPassword user@(User u) = check (not <$> isLockedPassword user) $
+ cmdProperty "passwd"
+ [ "--lock"
+ , u
+ ]
+ `assume` MadeChange
+ `describe` ("locked " ++ u ++ " password")
data PasswordStatus = NoPassword | LockedPassword | HasPassword
deriving (Eq)
@@ -99,11 +109,13 @@ homedir :: User -> IO FilePath
homedir (User user) = homeDirectory <$> getUserEntryForName user
hasGroup :: User -> Group -> Property NoInfo
-hasGroup (User user) (Group group') = check test $ cmdProperty "adduser"
- [ user
- , group'
- ]
- `describe` unwords ["user", user, "in group", group']
+hasGroup (User user) (Group group') = check test $
+ cmdProperty "adduser"
+ [ user
+ , group'
+ ]
+ `assume` MadeChange
+ `describe` unwords ["user", user, "in group", group']
where
test = not . elem group' . words <$> readProcess "groups" [user]
@@ -140,9 +152,11 @@ hasDesktopGroups user@(User u) = property desc $ do
shadowConfig :: Bool -> Property NoInfo
shadowConfig True = check (not <$> shadowExists) $
cmdProperty "shadowconfig" ["on"]
+ `assume` MadeChange
`describe` "shadow passwords enabled"
shadowConfig False = check shadowExists $
cmdProperty "shadowconfig" ["off"]
+ `assume` MadeChange
`describe` "shadow passwords disabled"
shadowExists :: IO Bool
@@ -156,6 +170,7 @@ hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabl
shellSetTo :: User -> FilePath -> Property NoInfo
shellSetTo (User u) loginshell = check needchangeshell $
cmdProperty "chsh" ["--shell", loginshell, u]
+ `assume` MadeChange
`describe` (u ++ " has login shell " ++ loginshell)
where
needchangeshell = do
diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs
index 6c2e1453..590d4ab9 100644
--- a/src/Propellor/Types/ResultCheck.hs
+++ b/src/Propellor/Types/ResultCheck.hs
@@ -5,6 +5,7 @@ module Propellor.Types.ResultCheck (
unchecked,
checkResult,
Checkable,
+ assume,
) where
import Propellor.Types
@@ -51,3 +52,15 @@ instance Checkable Property i where
instance Checkable UncheckedProperty i where
checkedProp (UncheckedProperty p) = p
+
+-- | 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 :: UncheckedProperty i -> Result -> Property i
+assume (UncheckedProperty p) result = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do
+ r <- satisfy
+ return (r <> result)