From 030f13f2d0501c9fb42c8f1efa0a15fa63c94d67 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Dec 2015 14:24:44 -0400 Subject: allow using `check` on a UncheckedProperty, which yields a Property --- src/Propellor/Property.hs | 8 ---- src/Propellor/Property/Apache.hs | 15 +++--- src/Propellor/Property/Apt.hs | 5 +- src/Propellor/Property/Cmd.hs | 5 +- src/Propellor/Property/DebianMirror.hs | 5 +- src/Propellor/Property/DiskImage.hs | 4 +- src/Propellor/Property/Group.hs | 6 +-- src/Propellor/Property/Locale.hs | 8 +--- src/Propellor/Property/Postfix.hs | 7 +-- .../Property/SiteSpecific/GitAnnexBuilder.hs | 1 - src/Propellor/Property/User.hs | 56 ++++++++++------------ src/Propellor/Types/ResultCheck.hs | 29 ++++++++--- 12 files changed, 65 insertions(+), 84 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index eacb6004..e862fb44 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -169,14 +169,6 @@ infixl 1 ==> ensureProperty :: Property NoInfo -> Propellor Result ensureProperty = catchPropellor . propertySatisfy --- | Makes a Property only need to do anything when a test succeeds. -check :: (LiftPropellor m) => m Bool -> Property i -> Property i -check c p = adjustPropertySatisfy p $ \satisfy -> - ifM (liftPropellor c) - ( satisfy - , return NoChange - ) - -- | Tries the first property, but if it fails to work, instead uses -- the second. fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2 diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index 626d3879..9e192e84 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -37,9 +37,8 @@ siteEnabled hn cf = enable disable [ siteAvailable hn cf `requires` installed `onChange` reloaded - , check (not <$> isenabled) $ - cmdProperty "a2ensite" ["--quiet", hn] - `assume` MadeChange + , check (not <$> isenabled) + (cmdProperty "a2ensite" ["--quiet", hn]) `requires` installed `onChange` reloaded ] @@ -63,15 +62,13 @@ siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ modEnabled :: String -> RevertableProperty NoInfo modEnabled modname = enable disable where - enable = check (not <$> isenabled) $ - cmdProperty "a2enmod" ["--quiet", modname] - `assume` MadeChange + enable = check (not <$> isenabled) + (cmdProperty "a2enmod" ["--quiet", modname]) `describe` ("apache module enabled " ++ modname) `requires` installed `onChange` reloaded - disable = check isenabled $ - cmdProperty "a2dismod" ["--quiet", modname] - `assume` MadeChange + disable = check isenabled + (cmdProperty "a2dismod" ["--quiet", modname]) `describe` ("apache module disabled " ++ modname) `requires` installed `onChange` reloaded diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index f25d8ee7..a177c42f 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -137,7 +137,6 @@ installed' params ps = robustly $ check (isInstallable ps) go `describe` (unwords $ "apt installed":ps) where go = runApt (params ++ ["install"] ++ ps) - `assume` MadeChange installedBackport :: [Package] -> Property NoInfo installedBackport ps = withOS desc $ \o -> case o of @@ -157,10 +156,8 @@ installedMin :: [Package] -> Property NoInfo installedMin = installed' ["--no-install-recommends", "-y"] removed :: [Package] -> Property NoInfo -removed ps = check (or <$> isInstalled' ps) go +removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) `describe` (unwords $ "apt removed":ps) - where - go = runApt (["-y", "remove"] ++ ps) `assume` MadeChange buildDep :: [Package] -> Property NoInfo buildDep ps = robustly $ go diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 3db00bc1..83414dcb 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -6,11 +6,10 @@ -- -- The best approach is to `check` a property, so that the command is only -- run when it needs to be. With this method, you avoid running the --- `cmdProperty` unnecessarily, and you know that whenever it runs, a --- change was made. +-- `cmdProperty` unnecessarily. -- -- > check (not <$> userExists "bob") --- > (cmdProperty "useradd" ["bob"] `assume` MadeChange) +-- > (cmdProperty "useradd" ["bob"]) -- -- Sometimes it's just as expensive to check a property as it would be to -- run the command that ensures the property. So you can let the command diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index 14024a4e..eea7b96f 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -126,9 +126,8 @@ 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 - `assume` MadeChange + , check (not . and <$> mapM suitemirrored suites) + (cmdProperty "debmirror" args) `describe` "debmirror setup" , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $ unwords ("/usr/bin/debmirror" : args) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 79237e61..6200f856 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -289,12 +289,10 @@ grubBooted bios = (Grub.installed' bios, boots) , inchroot "update-initramfs" ["-u"] `assume` MadeChange -- work around for http://bugs.debian.org/802717 - , check haveosprober $ inchroot "chmod" ["-x", osprober] - `assume` MadeChange + , check haveosprober $ inchroot "chmod" ["-x", osprober] , 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 diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs index 8499d636..f91ef1c2 100644 --- a/src/Propellor/Property/Group.hs +++ b/src/Propellor/Property/Group.hs @@ -5,10 +5,8 @@ import Propellor.Base type GID = Int exists :: Group -> Maybe GID -> Property NoInfo -exists (Group group') mgid = check test $ - cmdProperty "addgroup" (args mgid) - `assume` MadeChange - `describe` unwords ["group", group'] +exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid)) + `describe` unwords ["group", group'] where groupFile = "/etc/group" test = not . elem group' . words <$> readProcess "cut" ["-d:", "-f1", groupFile] diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs index 29de8df2..a9fb3514 100644 --- a/src/Propellor/Property/Locale.hs +++ b/src/Propellor/Property/Locale.hs @@ -24,15 +24,11 @@ type LocaleVariable = String selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo locale `selectedFor` vars = select deselect where - select = check (not <$> isselected) select' + select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs) `requires` available locale `describe` (locale ++ " locale selected") - select' = cmdProperty "update-locale" selectArgs - `assume` MadeChange - deselect = check isselected deselect' + deselect = check isselected (cmdProperty "update-locale" vars) `describe` (locale ++ " locale deselected") - deselect' = cmdProperty "update-locale" vars - `assume` MadeChange selectArgs = zipWith (++) vars (repeat ('=':locale)) isselected = locale `isSelectedFor` vars diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index e9fdfc38..1c8684c7 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -60,9 +60,8 @@ mappedFile f setup = setup f -- | Run newaliases command, which should be done after changing -- @/etc/aliases@. newaliases :: Property NoInfo -newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") $ - cmdProperty "newaliases" [] - `assume` MadeChange +newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") + (cmdProperty "newaliases" []) -- | The main config file for postfix. mainCfFile :: FilePath @@ -76,7 +75,6 @@ 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) @@ -162,7 +160,6 @@ 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/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index a34071ce..2312846c 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -65,7 +65,6 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props 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 diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index 84d20e62..ea88a1b3 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -8,28 +8,26 @@ import qualified Propellor.Property.File as File data Eep = YesReallyDeleteHome accountFor :: User -> Property NoInfo -accountFor user@(User u) = check nohomedir $ - cmdProperty "adduser" +accountFor user@(User u) = check nohomedir go + `describe` ("account for " ++ u) + where + nohomedir = isNothing <$> catchMaybeIO (homedir user) + go = 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 hashomedir $ - cmdProperty "userdel" +nuked user@(User u) _ = check hashomedir go + `describe` ("nuked user " ++ u) + where + hashomedir = isJust <$> catchMaybeIO (homedir user) + go = 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. @@ -83,13 +81,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" +lockedPassword user@(User u) = check (not <$> isLockedPassword user) go + `describe` ("locked " ++ u ++ " password") + where + go = cmdProperty "passwd" [ "--lock" , u ] - `assume` MadeChange - `describe` ("locked " ++ u ++ " password") data PasswordStatus = NoPassword | LockedPassword | HasPassword deriving (Eq) @@ -109,15 +107,14 @@ homedir :: User -> IO FilePath homedir (User user) = homeDirectory <$> getUserEntryForName user hasGroup :: User -> Group -> Property NoInfo -hasGroup (User user) (Group group') = check test $ - cmdProperty "adduser" +hasGroup (User user) (Group group') = check test go + `describe` unwords ["user", user, "in group", group'] + where + test = not . elem group' . words <$> readProcess "groups" [user] + go = cmdProperty "adduser" [ user , group' ] - `assume` MadeChange - `describe` unwords ["user", user, "in group", group'] - where - test = not . elem group' . words <$> readProcess "groups" [user] -- | Gives a user access to the secondary groups, including audio and -- video, that the OS installer normally gives a desktop user access to. @@ -150,13 +147,11 @@ hasDesktopGroups user@(User u) = property desc $ do -- | Controls whether shadow passwords are enabled or not. shadowConfig :: Bool -> Property NoInfo -shadowConfig True = check (not <$> shadowExists) $ - cmdProperty "shadowconfig" ["on"] - `assume` MadeChange +shadowConfig True = check (not <$> shadowExists) + (cmdProperty "shadowconfig" ["on"]) `describe` "shadow passwords enabled" -shadowConfig False = check shadowExists $ - cmdProperty "shadowconfig" ["off"] - `assume` MadeChange +shadowConfig False = check shadowExists + (cmdProperty "shadowconfig" ["off"]) `describe` "shadow passwords disabled" shadowExists :: IO Bool @@ -168,9 +163,8 @@ hasLoginShell :: User -> FilePath -> Property NoInfo hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell shellSetTo :: User -> FilePath -> Property NoInfo -shellSetTo (User u) loginshell = check needchangeshell $ - cmdProperty "chsh" ["--shell", loginshell, u] - `assume` MadeChange +shellSetTo (User u) loginshell = check needchangeshell + (cmdProperty "chsh" ["--shell", loginshell, u]) `describe` (u ++ " has login shell " ++ loginshell) where needchangeshell = do diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs index 09fbf73b..4c6524ee 100644 --- a/src/Propellor/Types/ResultCheck.hs +++ b/src/Propellor/Types/ResultCheck.hs @@ -4,15 +4,16 @@ module Propellor.Types.ResultCheck ( UncheckedProperty, unchecked, checkResult, + check, Checkable, assume, ) where import Propellor.Types import Propellor.Exception +import Utility.Monad import Data.Monoid -import Control.Monad.IO.Class (liftIO) -- | This is a `Property` but its `Result` is not accurate; in particular -- it may return `NoChange` despite having made a change. @@ -29,30 +30,44 @@ unchecked = UncheckedProperty -- `UncheckedProperty` to a `Property`, but can also be used to further -- check a `Property`. checkResult - :: Checkable p i - => IO a + :: (Checkable p i, LiftPropellor m) + => m a -- ^ Run before ensuring the property. - -> (a -> IO Result) + -> (a -> m Result) -- ^ Run after ensuring the property. Return `MadeChange` if a -- change was detected, or `NoChange` if no change was detected. -> p i -> Property i checkResult precheck postcheck p = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do - a <- liftIO precheck + a <- liftPropellor precheck r <- catchPropellor satisfy -- Always run postcheck, even if the result is already MadeChange, -- as it may need to clean up after precheck. - r' <- liftIO $ postcheck a + r' <- liftPropellor $ postcheck a return (r <> r') - + +-- | Makes a `Property` or an `UncheckedProperty` only run +-- when a test succeeds. +check :: (Checkable p i, LiftPropellor m) => m Bool -> p i -> Property i +check test p = adjustPropertySatisfy (preCheckedProp p) $ \satisfy -> + ifM (liftPropellor test) + ( satisfy + , return NoChange + ) + class Checkable p i where checkedProp :: p i -> Property i + preCheckedProp :: p i -> Property i instance Checkable Property i where checkedProp = id + preCheckedProp = id instance Checkable UncheckedProperty i where checkedProp (UncheckedProperty p) = p + -- Since it was pre-checked that the property needed to be run, + -- if the property succeeded, we can assume it made a change. + preCheckedProp (UncheckedProperty p) = p `assume` MadeChange -- | Sometimes it's not practical to test if a property made a change. -- In such a case, it's often fine to say: -- cgit v1.2.3