From 12548bae3d8feecce6a322162d91b827289ae824 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 5 Dec 2015 17:52:43 -0400 Subject: UncheckedProperty for cmdProperty et al * 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. --- src/Propellor/Property/Apache.hs | 5 +- src/Propellor/Property/Apt.hs | 38 ++++++++++----- src/Propellor/Property/Chroot.hs | 1 + src/Propellor/Property/Cmd.hs | 27 ++++++---- src/Propellor/Property/DebianMirror.hs | 6 ++- src/Propellor/Property/DiskImage.hs | 6 +++ src/Propellor/Property/Docker.hs | 11 +++-- src/Propellor/Property/File.hs | 16 +++--- src/Propellor/Property/Git.hs | 47 ++++++++++++------ src/Propellor/Property/Group.hs | 6 ++- src/Propellor/Property/Grub.hs | 7 ++- .../Property/HostingProvider/CloudAtCost.hs | 4 +- src/Propellor/Property/Hostname.hs | 7 +-- src/Propellor/Property/Locale.hs | 12 +++-- src/Propellor/Property/Mount.hs | 1 + src/Propellor/Property/Network.hs | 1 + src/Propellor/Property/Parted.hs | 7 +-- src/Propellor/Property/Partition.hs | 5 +- src/Propellor/Property/Postfix.hs | 7 ++- src/Propellor/Property/Reboot.hs | 1 + src/Propellor/Property/Rsync.hs | 1 + src/Propellor/Property/Service.hs | 8 +-- src/Propellor/Property/SiteSpecific/Branchable.hs | 2 +- .../Property/SiteSpecific/GitAnnexBuilder.hs | 8 ++- src/Propellor/Property/SiteSpecific/GitHome.hs | 2 + src/Propellor/Property/SiteSpecific/IABak.hs | 19 +++++--- src/Propellor/Property/SiteSpecific/JoeySites.hs | 13 +++-- src/Propellor/Property/Ssh.hs | 4 +- src/Propellor/Property/Systemd.hs | 32 +++++++----- src/Propellor/Property/User.hs | 57 ++++++++++++++-------- 30 files changed, 238 insertions(+), 123 deletions(-) (limited to 'src/Propellor/Property') 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 -- 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 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 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 -- cgit v1.2.3