get rid of AttrProperty

Now both Property and RevertableProperty can influence Attr on their own.

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 -> (Attr -> Attr) -> Property 
-pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
+pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
-	(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 }
 

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

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
+p `onChange` hook = property (propertyDesc p) $ do
-	r <- ensureProperty property
+	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)
+check c p = property (propertyDesc p) $ ifM (liftIO c)
-	( ensureProperty property
+	( 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
 	)

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)

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

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 :: String -> RunParam -> Property
-runProp field val = AttrProperty prop $ \attr ->
+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 :: String -> (HostName -> RunParam) -> Property
-genProp field mkval = AttrProperty prop $ \attr ->
+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

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

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

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

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

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)

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")

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
 

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

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

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"]
 			]

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"]

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 writeFile (SshPubKey keytype "") ".pub")
-	, Property desc (install writeFileProtected (SshPrivKey keytype "") "")
+	, 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 writeFile (SshPubKey keytype user) ".pub")
-	, Property desc (install writeFileProtected (SshPrivKey keytype user) "")
+	, 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

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

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

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
+	getAttr = propertyAttr
-		r <- propertySatisfy y
+	x `requires` y = Property (propertyDesc x) satisfy attr
-		case r of
+	  where
-			FailedChange -> return FailedChange
+	  	attr = propertyAttr x . propertyAttr y
-			_ -> propertySatisfy x
+		satisfy = do
-	getAttr _ = id
+			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
+	-- | Gets the Attr of the currently active side.
-
+	getAttr (RevertableProperty p1 _p2) = getAttr p1
-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
 
 type Desc = String
 

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

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>