summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-12-06 14:33:22 -0400
committerJoey Hess2015-12-06 14:33:22 -0400
commit6c7ad5b021ae46be1fda3004f9c578ab2471d9aa (patch)
tree4319434104db22cc4598746eeb2d6fbf244ed7be /src
parent616c6c2e2c2c7dcafa9bc72c7c1bdea650e43e43 (diff)
parent516b7cb886470c6a86d4022d7cf20a8547a98bd9 (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property.hs53
-rw-r--r--src/Propellor/Property/Apache.hs15
-rw-r--r--src/Propellor/Property/Apt.hs7
-rw-r--r--src/Propellor/Property/Cmd.hs32
-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/Grub.hs5
-rw-r--r--src/Propellor/Property/Hostname.hs42
-rw-r--r--src/Propellor/Property/Journald.hs3
-rw-r--r--src/Propellor/Property/Locale.hs13
-rw-r--r--src/Propellor/Property/Postfix.hs20
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs1
-rw-r--r--src/Propellor/Property/Systemd.hs2
-rw-r--r--src/Propellor/Property/User.hs56
-rw-r--r--src/Propellor/Types/ResultCheck.hs29
16 files changed, 175 insertions, 118 deletions
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 2976acf1..e862fb44 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -28,6 +28,8 @@ module Propellor.Property (
, UncheckedProperty
, unchecked
, changesFile
+ , changesFileContent
+ , isNewerThan
, checkResult
, Checkable
, assume
@@ -36,10 +38,12 @@ module Propellor.Property (
import System.Directory
import System.FilePath
import Control.Monad
+import Control.Applicative
import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
+import qualified Data.Hash.MD5 as MD5
import Propellor.Types
import Propellor.Types.ResultCheck
@@ -47,6 +51,7 @@ import Propellor.Info
import Propellor.Exception
import Utility.Exception
import Utility.Monad
+import Utility.Misc
-- | Constructs a Property, from a description and an action to run to
-- ensure the Property is met.
@@ -164,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
@@ -185,11 +182,12 @@ fallback = combineWith combiner revertcombiner
revertcombiner = (<>)
-- | Indicates that a Property may change a particular file. When the file
--- is modified, the property will return MadeChange instead of NoChange.
+-- is modified in any way (including changing its permissions or mtime),
+-- the property will return MadeChange instead of NoChange.
changesFile :: Checkable p i => p i -> FilePath -> Property i
changesFile p f = checkResult getstat comparestat p
where
- getstat = liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
+ getstat = catchMaybeIO $ getSymbolicLinkStatus f
comparestat oldstat = do
newstat <- getstat
return $ if samestat oldstat newstat then NoChange else MadeChange
@@ -214,6 +212,41 @@ changesFile p f = checkResult getstat comparestat p
]
samestat _ _ = False
+-- | Like `changesFile`, but compares the content of the file.
+-- Changes to mtime etc that do not change file content are treated as
+-- NoChange.
+changesFileContent :: Checkable p i => p i -> FilePath -> Property i
+changesFileContent p f = checkResult getmd5 comparemd5 p
+ where
+ getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f
+ comparemd5 oldmd5 = do
+ newmd5 <- getmd5
+ return $ if oldmd5 == newmd5 then NoChange else MadeChange
+
+-- | Determines if the first file is newer than the second file.
+--
+-- This can be used with `check` to only run a command when a file
+-- has changed.
+--
+-- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
+-- > (cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db
+--
+-- Or it can be used with `checkResult` to test if a command made a change.
+--
+-- > checkResult (return ())
+-- > (\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases")
+-- > (cmdProperty "newaliases" [])
+--
+-- (If one of the files does not exist, the file that does exist is
+-- considered to be the newer of the two.)
+isNewerThan :: FilePath -> FilePath -> IO Bool
+isNewerThan x y = do
+ mx <- mtime x
+ my <- mtime y
+ return (mx > my)
+ where
+ mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
+
-- | Makes a property that is satisfied differently depending on the host's
-- operating system.
--
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 26c151d9..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
@@ -304,7 +301,7 @@ aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-- space.
cacheCleaned :: Property NoInfo
cacheCleaned = cmdProperty "apt-get" ["clean"]
- `assume` MadeChange
+ `assume` NoChange
`describe` "apt cache cleaned"
-- | Add a foreign architecture to dpkg and apt.
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index b02376a3..83414dcb 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -1,7 +1,32 @@
{-# LANGUAGE PackageImports #-}
+-- | This module lets you construct Properties by running commands and
+-- scripts. To get from an `UncheckedProperty` to a `Property`, it's
+-- up to the user to check if the command made a change to the system.
+--
+-- The best approach is to `check` a property, so that the command is only
+-- run when it needs to be. With this method, you avoid running the
+-- `cmdProperty` unnecessarily.
+--
+-- > check (not <$> userExists "bob")
+-- > (cmdProperty "useradd" ["bob"])
+--
+-- Sometimes it's just as expensive to check a property as it would be to
+-- run the command that ensures the property. So you can let the command
+-- run every time, and use `changesFile` or `checkResult` to determine if
+-- anything changed:
+--
+-- > cmdProperty "chmod" ["600", "/etc/secret"]
+-- > `changesFile` "/etc/secret"
+--
+-- Or you can punt and `assume` a change was made, but then propellor will
+-- always say it make a change, and `onChange` will always fire.
+--
+-- > cmdProperty "service" ["foo", "reload"]
+-- > `assume` MadeChange
+
module Propellor.Property.Cmd (
- -- * Properties for running commands and scripts
+ -- * Constricting properties running commands and scripts
cmdProperty,
cmdProperty',
cmdPropertyEnv,
@@ -32,11 +57,6 @@ import Utility.Process (createProcess, CreateProcess, waitForProcess)
-- | A property that can be satisfied by running a command.
--
-- The command must exit 0 on success.
---
--- 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
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/Grub.hs b/src/Propellor/Property/Grub.hs
index 024a2827..1b7f2a0a 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -20,11 +20,10 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
--
-- This includes running update-grub.
installed :: BIOS -> Property NoInfo
-installed bios = installed' bios `before` mkConfig
+installed bios = installed' bios `onChange` mkConfig
-- Run update-grub, to generate the grub boot menu. It will be
--- automatically updated when kernel packages are
--- -- installed.
+-- automatically updated when kernel packages are installed.
mkConfig :: Property NoInfo
mkConfig = cmdProperty "update-grub" []
`assume` MadeChange
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index fcb88f59..7ab350ae 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -35,31 +35,33 @@ setTo :: HostName -> Property NoInfo
setTo = setTo' extractDomain
setTo' :: ExtractDomain -> HostName -> Property NoInfo
-setTo' extractdomain hn = combineProperties desc go
+setTo' extractdomain hn = combineProperties desc
+ [ "/etc/hostname" `File.hasContent` [basehost]
+ , hostslines $ catMaybes
+ [ if null domain
+ then Nothing
+ else Just ("127.0.1.1", [hn, basehost])
+ , Just ("127.0.0.1", ["localhost"])
+ ]
+ , check (not <$> inChroot) $
+ cmdProperty "hostname" [basehost]
+ `assume` NoChange
+ , "/etc/mailname" `File.hasContent`
+ [if null domain then hn else domain]
+ ]
where
desc = "hostname " ++ hn
basehost = takeWhile (/= '.') hn
domain = extractdomain hn
-
- go = catMaybes
- [ Just $ "/etc/hostname" `File.hasContent` [basehost]
- , if null domain
- then Nothing
- else Just $ 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]
- ]
- hostsline ip names = File.fileProperty desc
- (addhostsline ip names)
- "/etc/hosts"
- addhostsline ip names ls =
- (ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls
- hasip ip l = headMaybe (words l) == Just ip
+ hostslines ipsnames =
+ File.fileProperty desc (addhostslines ipsnames) "/etc/hosts"
+ addhostslines :: [(String, [String])] -> [String] -> [String]
+ addhostslines ipsnames ls =
+ let ips = map fst ipsnames
+ hasip l = maybe False (`elem` ips) (headMaybe (words l))
+ mkline (ip, names) = ip ++ "\t" ++ (unwords names)
+ in map mkline ipsnames ++ filter (not . hasip) ls
-- | Makes </etc/resolv.conf> contain search and domain lines for
-- the domain that the hostname is in.
diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs
index 6c8bda80..2fbb780e 100644
--- a/src/Propellor/Property/Journald.hs
+++ b/src/Propellor/Property/Journald.hs
@@ -17,7 +17,8 @@ type DataSize = String
configuredSize :: Systemd.Option -> DataSize -> Property NoInfo
configuredSize option s = case readSize dataUnits s of
Just sz -> configured option (systemdSizeUnits sz)
- Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange
+ Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $
+ return FailedChange
systemMaxUse :: DataSize -> Property NoInfo
systemMaxUse = configuredSize "SystemMaxUse"
diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs
index 0342a2f2..a9fb3514 100644
--- a/src/Propellor/Property/Locale.hs
+++ b/src/Propellor/Property/Locale.hs
@@ -24,14 +24,19 @@ type LocaleVariable = String
selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo
locale `selectedFor` vars = select <!> deselect
where
- select = cmdProperty "update-locale" selectArgs
- `assume` NoChange
+ select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs)
`requires` available locale
`describe` (locale ++ " locale selected")
- deselect = cmdProperty "update-locale" vars
- `assume` NoChange
+ deselect = check isselected (cmdProperty "update-locale" vars)
`describe` (locale ++ " locale deselected")
selectArgs = zipWith (++) vars (repeat ('=':locale))
+ isselected = locale `isSelectedFor` vars
+
+isSelectedFor :: Locale -> [LocaleVariable] -> IO Bool
+locale `isSelectedFor` vars = do
+ ls <- catchDefaultIO [] $ lines <$> readFile "/etc/default/locale"
+ return $ and $ map (\v -> v ++ "=" ++ locale `elem` ls) vars
+
-- | Ensures a locale is generated (or, if reverted, ensure it's not).
--
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index bc46ac21..1c8684c7 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -60,8 +60,8 @@ mappedFile f setup = setup f
-- | Run newaliases command, which should be done after changing
-- @/etc/aliases@.
newaliases :: Property NoInfo
-newaliases = cmdProperty "newaliases" []
- `assume` MadeChange
+newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
+ (cmdProperty "newaliases" [])
-- | The main config file for postfix.
mainCfFile :: FilePath
@@ -75,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)
@@ -161,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"
@@ -170,15 +168,17 @@ saslAuthdInstalled = setupdaemon
--
-- The password is taken from the privdata.
saslPasswdSet :: Domain -> User -> Property HasInfo
-saslPasswdSet domain (User user) = withPrivData src ctx $ \getpw -> trivial $
- property ("sasl password for " ++ uatd) $ getpw $ \pw -> makeChange $
- withHandle StdinHandle createProcessSuccess p $ \h -> do
- hPutStrLn h (privDataVal pw)
- hClose h
+saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"
where
+ go = withPrivData src ctx $ \getpw ->
+ property desc $ getpw $ \pw -> liftIO $
+ withHandle StdinHandle createProcessSuccess p $ \h -> do
+ hPutStrLn h (privDataVal pw)
+ hClose h
+ return NoChange
+ desc = "sasl password for " ++ uatd
uatd = user ++ "@" ++ domain
ps = ["-p", "-c", "-u", domain, user]
p = proc "saslpasswd2" ps
ctx = Context "sasl"
src = PrivDataSource (Password uatd) "enter password"
- trivial = flip assume NoChange
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/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 04ce3b48..5a08fb1e 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -158,7 +158,7 @@ configured cfgfile option value = combineProperties desc
line = setting ++ value
desc = cfgfile ++ " " ++ line
removeother l
- | setting `isPrefixOf` l = Nothing
+ | setting `isPrefixOf` l && l /= line = Nothing
| otherwise = Just l
-- | Causes systemd to reload its configuration files.
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: