summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-12-06 14:24:44 -0400
committerJoey Hess2015-12-06 14:24:44 -0400
commit030f13f2d0501c9fb42c8f1efa0a15fa63c94d67 (patch)
treef81cbf9524d258daea72ab09866a6a8fe526c827
parent94f91a44810dc3a1eca95c843e3c444cbbe87006 (diff)
allow using `check` on a UncheckedProperty, which yields a Property
-rw-r--r--src/Propellor/Property.hs8
-rw-r--r--src/Propellor/Property/Apache.hs15
-rw-r--r--src/Propellor/Property/Apt.hs5
-rw-r--r--src/Propellor/Property/Cmd.hs5
-rw-r--r--src/Propellor/Property/DebianMirror.hs5
-rw-r--r--src/Propellor/Property/DiskImage.hs4
-rw-r--r--src/Propellor/Property/Group.hs6
-rw-r--r--src/Propellor/Property/Locale.hs8
-rw-r--r--src/Propellor/Property/Postfix.hs7
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs1
-rw-r--r--src/Propellor/Property/User.hs56
-rw-r--r--src/Propellor/Types/ResultCheck.hs29
12 files changed, 65 insertions, 84 deletions
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: