summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Propellor/Attr.hs17
-rw-r--r--Propellor/Engine.hs2
-rw-r--r--Propellor/Property.hs26
-rw-r--r--Propellor/Property/Apt.hs6
-rw-r--r--Propellor/Property/Cmd.hs2
-rw-r--r--Propellor/Property/Docker.hs49
-rw-r--r--Propellor/Property/File.hs12
-rw-r--r--Propellor/Property/Git.hs2
-rw-r--r--Propellor/Property/Gpg.hs2
-rw-r--r--Propellor/Property/Hostname.hs2
-rw-r--r--Propellor/Property/Obnam.hs2
-rw-r--r--Propellor/Property/Postfix.hs2
-rw-r--r--Propellor/Property/Scheduled.hs4
-rw-r--r--Propellor/Property/Service.hs6
-rw-r--r--Propellor/Property/SiteSpecific/GitAnnexBuilder.hs2
-rw-r--r--Propellor/Property/SiteSpecific/GitHome.hs6
-rw-r--r--Propellor/Property/SiteSpecific/JoeySites.hs2
-rw-r--r--Propellor/Property/Ssh.hs16
-rw-r--r--Propellor/Property/Sudo.hs2
-rw-r--r--Propellor/Property/User.hs2
-rw-r--r--Propellor/Types.hs37
-rw-r--r--debian/changelog3
-rw-r--r--propellor.cabal2
23 files changed, 102 insertions, 104 deletions
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index 94376b0d..d4fb25d2 100644
--- a/Propellor/Attr.hs
+++ b/Propellor/Attr.hs
@@ -10,36 +10,35 @@ import qualified Data.Set as S
import qualified Data.Map as M
import Control.Applicative
-pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty
-pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
- (return NoChange)
+pureAttrProperty :: Desc -> (Attr -> Attr) -> Property
+pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
-hostname :: HostName -> AttrProperty
+hostname :: HostName -> Property
hostname name = pureAttrProperty ("hostname " ++ name) $
\d -> d { _hostname = name }
getHostName :: Propellor HostName
getHostName = asks _hostname
-os :: System -> AttrProperty
+os :: System -> Property
os system = pureAttrProperty ("Operating " ++ show system) $
\d -> d { _os = Just system }
getOS :: Propellor (Maybe System)
getOS = asks _os
-cname :: Domain -> AttrProperty
+cname :: Domain -> Property
cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
-cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
+cnameFor :: Domain -> (Domain -> Property) -> Property
cnameFor domain mkp =
let p = mkp domain
- in AttrProperty p (addCName domain)
+ in p { propertyAttr = propertyAttr p . addCName domain }
addCName :: HostName -> Attr -> Attr
addCName domain d = d { _cnames = S.insert domain (_cnames d) }
-sshPubKey :: String -> AttrProperty
+sshPubKey :: String -> Property
sshPubKey k = pureAttrProperty ("ssh pubkey known") $
\d -> d { _sshPubKey = Just k }
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
index 81d979ac..c697d853 100644
--- a/Propellor/Engine.hs
+++ b/Propellor/Engine.hs
@@ -18,7 +18,7 @@ runPropellor attr a = runReaderT (runWithAttr a) attr
mainProperties :: Attr -> [Property] -> IO ()
mainProperties attr ps = do
r <- runPropellor attr $
- ensureProperties [Property "overall" $ ensureProperties ps]
+ ensureProperties [property "overall" $ ensureProperties ps]
setTitle "propellor: done"
hFlush stdout
case r of
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index 5b1800ef..aa419069 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -26,12 +26,12 @@ noChange = return NoChange
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc $ ensureProperties ps
+propertyList desc ps = property desc $ ensureProperties ps
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn, stopping on failure.
combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc $ go ps NoChange
+combineProperties desc ps = property desc $ go ps NoChange
where
go [] rs = return rs
go (l:ls) rs = do
@@ -44,7 +44,7 @@ combineProperties desc ps = Property desc $ go ps NoChange
-- that ensures the first, and if the first succeeds, ensures the second.
-- The property uses the description of the first property.
before :: Property -> Property -> Property
-p1 `before` p2 = Property (propertyDesc p1) $ do
+p1 `before` p2 = property (propertyDesc p1) $ do
r <- ensureProperty p1
case r of
FailedChange -> return FailedChange
@@ -54,16 +54,16 @@ p1 `before` p2 = Property (propertyDesc p1) $ do
-- file to indicate whether it has run before.
-- Use with caution.
flagFile :: Property -> FilePath -> Property
-flagFile property = flagFile' property . return
+flagFile p = flagFile' p . return
flagFile' :: Property -> IO FilePath -> Property
-flagFile' property getflagfile = Property (propertyDesc property) $ do
+flagFile' p getflagfile = property (propertyDesc p) $ do
flagfile <- liftIO getflagfile
go flagfile =<< liftIO (doesFileExist flagfile)
where
go _ True = return NoChange
go flagfile False = do
- r <- ensureProperty property
+ r <- ensureProperty p
when (r == MadeChange) $ liftIO $
unlessM (doesFileExist flagfile) $ do
createDirectoryIfMissing True (takeDirectory flagfile)
@@ -73,8 +73,8 @@ flagFile' property getflagfile = Property (propertyDesc property) $ do
--- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange :: Property -> Property -> Property
-property `onChange` hook = Property (propertyDesc property) $ do
- r <- ensureProperty property
+p `onChange` hook = property (propertyDesc p) $ do
+ r <- ensureProperty p
case r of
MadeChange -> do
r' <- ensureProperty hook
@@ -87,8 +87,8 @@ infixl 1 ==>
-- | Makes a Property only be performed when a test succeeds.
check :: IO Bool -> Property -> Property
-check c property = Property (propertyDesc property) $ ifM (liftIO c)
- ( ensureProperty property
+check c p = property (propertyDesc p) $ ifM (liftIO c)
+ ( ensureProperty p
, return NoChange
)
@@ -99,7 +99,7 @@ check c property = Property (propertyDesc property) $ ifM (liftIO c)
-- to be made as it is to just idempotently assure the property is
-- satisfied. For example, chmodding a file.
trivial :: Property -> Property
-trivial p = Property (propertyDesc p) $ do
+trivial p = property (propertyDesc p) $ do
r <- ensureProperty p
if r == MadeChange
then return NoChange
@@ -110,10 +110,10 @@ trivial p = Property (propertyDesc p) $ do
--
-- Note that the operating system may not be declared for some hosts.
withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
-withOS desc a = Property desc $ a =<< getOS
+withOS desc a = property desc $ a =<< getOS
boolProperty :: Desc -> IO Bool -> Property
-boolProperty desc a = Property desc $ ifM (liftIO a)
+boolProperty desc a = property desc $ ifM (liftIO a)
( return MadeChange
, return FailedChange
)
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index d31e8b46..2115dc50 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -157,7 +157,7 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
robustly :: Property -> Property
-robustly p = Property (propertyDesc p) $ do
+robustly p = property (propertyDesc p) $ do
r <- ensureProperty p
if r == FailedChange
then ensureProperty $ p `requires` update
@@ -210,7 +210,7 @@ reConfigure :: Package -> [(String, String, String)] -> Property
reConfigure package vals = reconfigure `requires` setselections
`describe` ("reconfigure " ++ package)
where
- setselections = Property "preseed" $ makeChange $
+ setselections = property "preseed" $ makeChange $
withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do
forM_ vals $ \(tmpl, tmpltype, value) ->
@@ -236,7 +236,7 @@ trustsKey k = RevertableProperty trust untrust
desc = "apt trusts key " ++ keyname k
f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
untrust = File.notPresent f
- trust = check (not <$> doesFileExist f) $ Property desc $ makeChange $ do
+ trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
withHandle StdinHandle createProcessSuccess
(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
hPutStr h (pubkey k)
diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs
index 875c1f9a..5b7494ee 100644
--- a/Propellor/Property/Cmd.hs
+++ b/Propellor/Property/Cmd.hs
@@ -25,7 +25,7 @@ cmdProperty cmd params = cmdProperty' cmd params []
-- | A property that can be satisfied by running a command,
-- with added environment.
cmdProperty' :: String -> [String] -> [(String, String)] -> Property
-cmdProperty' cmd params env = Property desc $ liftIO $ do
+cmdProperty' cmd params env = property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment
ifM (boolSystemEnv cmd (map Param params) (Just env'))
( return MadeChange
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index d2555ea5..e05a8dd3 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -25,7 +25,7 @@ import Data.List.Utils
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io.
configured :: Property
-configured = Property "docker configured" go `requires` installed
+configured = property "docker configured" go `requires` installed
where
go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $
"/root/.dockercfg" `File.hasContent` (lines cfg)
@@ -64,7 +64,7 @@ docked
-> RevertableProperty
docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
where
- go desc a = Property (desc ++ " " ++ cn) $ do
+ go desc a = property (desc ++ " " ++ cn) $ do
hn <- getHostName
let cid = ContainerId hn cn
ensureProperties [findContainer hosts cid cn $ a cid]
@@ -79,7 +79,7 @@ docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown
teardown cid (Container image _runparams) =
combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid
- , Property ("cleaned up " ++ fromContainerId cid) $
+ , property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
[ removeContainer cid
, removeImage image
@@ -96,7 +96,7 @@ findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
Nothing -> cantfind
Just h -> maybe cantfind mk (mkContainer cid h)
where
- cantfind = containerDesc cid $ Property "" $ do
+ cantfind = containerDesc cid $ property "" $ do
liftIO $ warningMessage $
"missing definition for docker container \"" ++ cn2hn cn
return FailedChange
@@ -126,9 +126,9 @@ garbageCollected = propertyList "docker garbage collected"
, gcimages
]
where
- gccontainers = Property "docker containers garbage collected" $
+ gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
- gcimages = Property "docker images garbage collected" $ do
+ gcimages = property "docker images garbage collected" $ do
liftIO $ report <$> (mapM removeImage =<< listImages)
data Container = Container Image [RunParam]
@@ -140,49 +140,49 @@ type RunParam = String
type Image = String
-- | Set custom dns server for container.
-dns :: String -> AttrProperty
+dns :: String -> Property
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> AttrProperty
+hostname :: String -> Property
hostname = runProp "hostname"
-- | Set name for container. (Normally done automatically.)
-name :: String -> AttrProperty
+name :: String -> Property
name = runProp "name"
-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> AttrProperty
+publish :: String -> Property
publish = runProp "publish"
-- | Username or UID for container.
-user :: String -> AttrProperty
+user :: String -> Property
user = runProp "user"
-- | Mount a volume
-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
-- With just a directory, creates a volume in the container.
-volume :: String -> AttrProperty
+volume :: String -> Property
volume = runProp "volume"
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> AttrProperty
+volumes_from :: ContainerName -> Property
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> AttrProperty
+workdir :: String -> Property
workdir = runProp "workdir"
-- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g
-memory :: String -> AttrProperty
+memory :: String -> Property
memory = runProp "memory"
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> AttrProperty
+link :: ContainerName -> ContainerAlias -> Property
link linkwith alias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias
@@ -230,7 +230,7 @@ containerDesc cid p = p `describe` desc
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property
-runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ Property "running" $ do
+runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
then do
@@ -324,7 +324,7 @@ chain s = case toContainerId s of
-- being run. So, retry connections to the client for up to
-- 1 minute.
provisionContainer :: ContainerId -> Property
-provisionContainer cid = containerDesc cid $ Property "provision" $ liftIO $ do
+provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
when (r /= FailedChange) $
@@ -356,7 +356,7 @@ stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
stoppedContainer :: ContainerId -> Property
-stoppedContainer cid = containerDesc cid $ Property desc $
+stoppedContainer cid = containerDesc cid $ property desc $
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( liftIO cleanup `after` ensureProperty
(boolProperty desc $ stopContainer cid)
@@ -405,18 +405,15 @@ listContainers status =
listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> AttrProperty
-runProp field val = AttrProperty prop $ \attr ->
+runProp :: String -> RunParam -> Property
+runProp field val = pureAttrProperty (param) $ \attr ->
attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
where
param = field++"="++val
- prop = Property (param) (return NoChange)
-genProp :: String -> (HostName -> RunParam) -> AttrProperty
-genProp field mkval = AttrProperty prop $ \attr ->
+genProp :: String -> (HostName -> RunParam) -> Property
+genProp field mkval = pureAttrProperty field $ \attr ->
attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
- where
- prop = Property field (return NoChange)
-- | The ContainerIdent of a container is written to
-- /.propellor-ident inside it. This can be checked to see if
diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs
index 8f23dab7..0b060177 100644
--- a/Propellor/Property/File.hs
+++ b/Propellor/Property/File.hs
@@ -18,7 +18,7 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f)
-- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600.
hasPrivContent :: FilePath -> Property
-hasPrivContent f = Property desc $ withPrivData (PrivFile f) $ \privcontent ->
+hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent ->
ensureProperty $ fileProperty' writeFileProtected desc
(\_oldcontent -> lines privcontent) f
where
@@ -48,13 +48,13 @@ f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property
-notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
+notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
makeChange $ nukeFile f
fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
fileProperty = fileProperty' writeFile
fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property
-fileProperty' writer desc a f = Property desc $ go =<< liftIO (doesFileExist f)
+fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
where
go True = do
ls <- liftIO $ lines <$> readFile f
@@ -74,12 +74,12 @@ fileProperty' writer desc a f = Property desc $ go =<< liftIO (doesFileExist f)
-- | Ensures a directory exists.
dirExists :: FilePath -> Property
-dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $
+dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
makeChange $ createDirectoryIfMissing True d
-- | Ensures that a file/dir has the specified owner and group.
ownerGroup :: FilePath -> UserName -> GroupName -> Property
-ownerGroup f owner group = Property (f ++ " owner " ++ og) $ do
+ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
r <- ensureProperty $ cmdProperty "chown" [og, f]
if r == FailedChange
then return r
@@ -89,6 +89,6 @@ ownerGroup f owner group = Property (f ++ " owner " ++ og) $ do
-- | Ensures that a file/dir has the specfied mode.
mode :: FilePath -> FileMode -> Property
-mode f v = Property (f ++ " mode " ++ show v) $ do
+mode f v = property (f ++ " mode " ++ show v) $ do
liftIO $ modifyFileMode f (\_old -> v)
noChange
diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs
index 1dae94bf..ba370e51 100644
--- a/Propellor/Property/Git.hs
+++ b/Propellor/Property/Git.hs
@@ -62,7 +62,7 @@ type Branch = String
--
-- A branch can be specified, to check out.
cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
-cloned owner url dir mbranch = check originurl (Property desc checkout)
+cloned owner url dir mbranch = check originurl (property desc checkout)
`requires` installed
where
desc = "git cloned " ++ url ++ " to " ++ dir
diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs
index e23111bb..64ea9fea 100644
--- a/Propellor/Property/Gpg.hs
+++ b/Propellor/Property/Gpg.hs
@@ -21,7 +21,7 @@ installed = Apt.installed ["gnupg"]
-- The GpgKeyId does not have to be a numeric id; it can just as easily
-- be a description of the key.
keyImported :: GpgKeyId -> UserName -> Property
-keyImported keyid user = flagFile' (Property desc go) genflag
+keyImported keyid user = flagFile' (property desc go) genflag
`requires` installed
where
desc = user ++ " has gpg key " ++ show keyid
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
index 30e0992d..031abb9d 100644
--- a/Propellor/Property/Hostname.hs
+++ b/Propellor/Property/Hostname.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.File as File
-- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is
-- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).
sane :: Property
-sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
+sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName)
setTo :: HostName -> Property
setTo hn = combineProperties desc go
diff --git a/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs
index 6fda218a..32374b57 100644
--- a/Propellor/Property/Obnam.hs
+++ b/Propellor/Property/Obnam.hs
@@ -65,7 +65,7 @@ backup dir crontimes params numclients = cronjob `describe` desc
-- The restore is performed atomically; restoring to a temp directory
-- and then moving it to the directory.
restored :: FilePath -> [ObnamParam] -> Property
-restored dir params = Property (dir ++ " restored by obnam") go
+restored dir params = property (dir ++ " restored by obnam") go
`requires` installed
where
go = ifM (liftIO needsRestore)
diff --git a/Propellor/Property/Postfix.hs b/Propellor/Property/Postfix.hs
index f4be27cf..9fa4a2c3 100644
--- a/Propellor/Property/Postfix.hs
+++ b/Propellor/Property/Postfix.hs
@@ -15,7 +15,7 @@ installed = Apt.serviceInstalledRunning "postfix"
satellite :: Property
satellite = setup `requires` installed
where
- setup = trivial $ Property "postfix satellite system" $ do
+ setup = trivial $ property "postfix satellite system" $ do
hn <- getHostName
ensureProperty $ Apt.reConfigure "postfix"
[ ("postfix/main_mailer_type", "select", "Satellite system")
diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs
index 769a3931..0e639129 100644
--- a/Propellor/Property/Scheduled.hs
+++ b/Propellor/Property/Scheduled.hs
@@ -19,7 +19,7 @@ import qualified Data.Map as M
-- This uses the description of the Property to keep track of when it was
-- last run.
period :: Property -> Recurrance -> Property
-period prop recurrance = Property desc $ do
+period prop recurrance = property desc $ do
lasttime <- liftIO $ getLastChecked (propertyDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
@@ -37,7 +37,7 @@ period prop recurrance = Property desc $ do
periodParse :: Property -> String -> Property
periodParse prop s = case toRecurrance s of
Just recurrance -> period prop recurrance
- Nothing -> Property "periodParse" $ do
+ Nothing -> property "periodParse" $ do
liftIO $ warningMessage $ "failed periodParse: " ++ s
noChange
diff --git a/Propellor/Property/Service.hs b/Propellor/Property/Service.hs
index c6498e57..14e769d0 100644
--- a/Propellor/Property/Service.hs
+++ b/Propellor/Property/Service.hs
@@ -13,19 +13,19 @@ type ServiceName = String
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
running :: ServiceName -> Property
-running svc = Property ("running " ++ svc) $ do
+running svc = property ("running " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]
return NoChange
restarted :: ServiceName -> Property
-restarted svc = Property ("restarted " ++ svc) $ do
+restarted svc = property ("restarted " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]
return NoChange
reloaded :: ServiceName -> Property
-reloaded svc = Property ("reloaded " ++ svc) $ do
+reloaded svc = property ("reloaded " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]
return NoChange
diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 204a9ca7..677aa760 100644
--- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -40,7 +40,7 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
-- The builduser account does not have a password set,
-- instead use the password privdata to hold the rsync server
-- password used to upload the built image.
- , Property "rsync password" $ do
+ , property "rsync password" $ do
let f = homedir </> "rsyncpassword"
if rsyncupload
then withPrivData (Password builduser) $ \p -> do
diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs
index ee46a9e4..6ed02146 100644
--- a/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/Propellor/Property/SiteSpecific/GitHome.hs
@@ -8,16 +8,16 @@ import Utility.SafeCommand
-- | Clones Joey Hess's git home directory, and runs its fixups script.
installedFor :: UserName -> Property
installedFor user = check (not <$> hasGitDir user) $
- Property ("githome " ++ user) (go =<< liftIO (homedir user))
+ property ("githome " ++ user) (go =<< liftIO (homedir user))
`requires` Apt.installed ["git"]
where
go home = do
let tmpdir = home </> "githome"
ensureProperty $ combineProperties "githome setup"
[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]
- , Property "moveout" $ makeChange $ void $
+ , property "moveout" $ makeChange $ void $
moveout tmpdir home
- , Property "rmdir" $ makeChange $ void $
+ , property "rmdir" $ makeChange $ void $
catchMaybeIO $ removeDirectory tmpdir
, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]
]
diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
index 9b4587ba..c939ddce 100644
--- a/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -30,7 +30,7 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
`requires` Ssh.keyImported SshRsa "root"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
, check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $
- Property "olduse.net spool in place" $ makeChange $ do
+ property "olduse.net spool in place" $ makeChange $ do
removeDirectoryRecursive newsspool
createSymbolicLink (datadir </> "news") newsspool
, Apt.installed ["leafnode"]
diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs
index a39792cf..a4f87678 100644
--- a/Propellor/Property/Ssh.hs
+++ b/Propellor/Property/Ssh.hs
@@ -67,7 +67,7 @@ randomHostKeys :: Property
randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restartSshd
where
- prop = Property "ssh random host keys" $ do
+ prop = property "ssh random host keys" $ do
void $ liftIO $ boolSystem "sh"
[ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*"
@@ -81,8 +81,8 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
-- (Uses a null username for host keys.)
hostKey :: SshKeyType -> Property
hostKey keytype = combineProperties desc
- [ Property desc (install writeFile (SshPubKey keytype "") ".pub")
- , Property desc (install writeFileProtected (SshPrivKey keytype "") "")
+ [ property desc (install writeFile (SshPubKey keytype "") ".pub")
+ , property desc (install writeFileProtected (SshPrivKey keytype "") "")
]
`onChange` restartSshd
where
@@ -98,8 +98,8 @@ hostKey keytype = combineProperties desc
-- from the site's PrivData.
keyImported :: SshKeyType -> UserName -> Property
keyImported keytype user = combineProperties desc
- [ Property desc (install writeFile (SshPubKey keytype user) ".pub")
- , Property desc (install writeFileProtected (SshPrivKey keytype user) "")
+ [ property desc (install writeFile (SshPubKey keytype user) ".pub")
+ , property desc (install writeFileProtected (SshPrivKey keytype user) "")
]
where
desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")"
@@ -108,7 +108,7 @@ keyImported keytype user = combineProperties desc
ifM (liftIO $ doesFileExist f)
( noChange
, ensureProperty $ combineProperties desc
- [ Property desc $
+ [ property desc $
withPrivData p $ \key -> makeChange $
writer f key
, File.ownerGroup f user user
@@ -126,7 +126,7 @@ fromKeyType SshEd25519 = "ed25519"
-- | Puts some host's ssh public key into the known_hosts file for a user.
knownHost :: [Host] -> HostName -> UserName -> Property
-knownHost hosts hn user = Property desc $
+knownHost hosts hn user = property desc $
go =<< fromHost hosts hn getSshPubKey
where
desc = user ++ " knows ssh key for " ++ hn
@@ -143,7 +143,7 @@ knownHost hosts hn user = Property desc $
-- | Makes a user have authorized_keys from the PrivData
authorizedKeys :: UserName -> Property
-authorizedKeys user = Property (user ++ " has authorized_keys") $
+authorizedKeys user = property (user ++ " has authorized_keys") $
withPrivData (SshAuthorizedKeys user) $ \v -> do
f <- liftIO $ dotFile "authorized_keys" user
liftIO $ do
diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs
index 66ceb580..68b56608 100644
--- a/Propellor/Property/Sudo.hs
+++ b/Propellor/Property/Sudo.hs
@@ -10,7 +10,7 @@ import Propellor.Property.User
-- | Allows a user to sudo. If the user has a password, sudo is configured
-- to require it. If not, NOPASSWORD is enabled for the user.
enabledFor :: UserName -> Property
-enabledFor user = Property desc go `requires` Apt.installed ["sudo"]
+enabledFor user = property desc go `requires` Apt.installed ["sudo"]
where
go = do
locked <- liftIO $ isLockedPassword user
diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs
index 8e7afd81..eef2a57e 100644
--- a/Propellor/Property/User.hs
+++ b/Propellor/Property/User.hs
@@ -29,7 +29,7 @@ hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $
hasPassword user
hasPassword :: UserName -> Property
-hasPassword user = Property (user ++ " has password") $
+hasPassword user = property (user ++ " has password") $
withPrivData (Password user) $ \password -> makeChange $
withHandle StdinHandle createProcessSuccess
(proc "chpasswd" []) $ \h -> do
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index fc767cd2..01be9a5a 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -8,8 +8,8 @@ module Propellor.Types
, HostName
, Propellor(..)
, Property(..)
+ , property
, RevertableProperty(..)
- , AttrProperty(..)
, IsProp
, describe
, toProp
@@ -53,16 +53,18 @@ newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
-- property.
data Property = Property
{ propertyDesc :: Desc
- -- | must be idempotent; may run repeatedly
, propertySatisfy :: Propellor Result
+ -- ^ must be idempotent; may run repeatedly
+ , propertyAttr :: Attr -> Attr
+ -- ^ a property can affect the overall Attr
}
+property :: Desc -> Propellor Result -> Property
+property d s = Property d s id
+
-- | A property that can be reverted.
data RevertableProperty = RevertableProperty Property Property
--- | A property that affects the Attr.
-data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
-
class IsProp p where
-- | Sets description.
describe :: p -> Desc -> p
@@ -75,12 +77,16 @@ class IsProp p where
instance IsProp Property where
describe p d = p { propertyDesc = d }
toProp p = p
- x `requires` y = Property (propertyDesc x) $ do
- r <- propertySatisfy y
- case r of
- FailedChange -> return FailedChange
- _ -> propertySatisfy x
- getAttr _ = id
+ getAttr = propertyAttr
+ x `requires` y = Property (propertyDesc x) satisfy attr
+ where
+ attr = propertyAttr x . propertyAttr y
+ satisfy = do
+ r <- propertySatisfy y
+ case r of
+ FailedChange -> return FailedChange
+ _ -> propertySatisfy x
+
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
@@ -89,13 +95,8 @@ instance IsProp RevertableProperty where
toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2
- getAttr _ = id
-
-instance IsProp AttrProperty where
- describe (AttrProperty p a) d = AttrProperty (describe p d) a
- toProp (AttrProperty p _) = toProp p
- (AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
- getAttr (AttrProperty _ a) = a
+ -- | Gets the Attr of the currently active side.
+ getAttr (RevertableProperty p1 _p2) = getAttr p1
type Desc = String
diff --git a/debian/changelog b/debian/changelog
index 3daeb395..3cef12dc 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,5 +1,6 @@
-propellor (0.3.2) UNRELEASED; urgency=medium
+propellor (0.4.0) UNRELEASED; urgency=medium
+ * Constructor of Property has changed (use property function instead).
* Run all cron jobs under chronic from moreutils to avoid unnecessary mails.
-- Joey Hess <joeyh@debian.org> Thu, 17 Apr 2014 21:00:43 -0400
diff --git a/propellor.cabal b/propellor.cabal
index ad171b5e..677b9a89 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 0.3.1
+Version: 0.4.0
Cabal-Version: >= 1.6
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>