Merge branch 'joeyconfig'

Conflicts:
	doc/todo/info_propigation_out_of_nested_properties.mdwn
	privdata.joey/privdata.gpg

config-joey.hs

@@ -25,6 +25,7 @@ import qualified Propellor.Property.Grub as Grub
 import qualified Propellor.Property.Obnam as Obnam
 import qualified Propellor.Property.Gpg as Gpg
 import qualified Propellor.Property.Systemd as Systemd
+import qualified Propellor.Property.Journald as Journald
 import qualified Propellor.Property.OS as OS
 import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
 import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
@@ -46,7 +47,6 @@ hosts =                --                  (o)  `
 	, kite
 	, diatom
 	, elephant
-	, testvm
 	] ++ monsters
 
 testvm :: Host
@@ -140,11 +140,13 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
 		, (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3")
 		]
 
+	& Network.static "eth0" `requires` Network.cleanInterfacesFile
 	& Apt.installed ["linux-image-amd64"]
 	& Linode.chainPVGrub 5
 	& Apt.unattendedUpgrades
 	& Systemd.installed
 	& Systemd.persistentJournal
+	& Journald.systemMaxUse "500MiB"
 	& Ssh.passwordAuthentication True
 	-- Since ssh password authentication is allowed:
 	& Apt.serviceInstalledRunning "fail2ban"
@@ -254,7 +256,7 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64"
 	& JoeySites.oldUseNetServer hosts
 	
 	& alias "ns2.kitenet.net"
-	& myDnsPrimary False "kitenet.net" []
+	& myDnsPrimary True "kitenet.net" []
 	& myDnsPrimary True "joeyh.name" []
 	& myDnsPrimary True "ikiwiki.info" []
 	& myDnsPrimary True "olduse.net"
@@ -327,13 +329,14 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	& Ssh.listenPort 80
 
 
-	    --'                        __|II|      ,.
+       --'                        __|II|      ,.
-	  ----                      __|II|II|__   (  \_,/\
+     ----                      __|II|II|__   (  \_,/\
-	 ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-
+--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-.-'-
-	----------------------- |      [Docker]       / ----------------------
+-------------------------- |      [Docker]       / --------------------------
-	----------------------- :                    / -----------------------
+-------------------------- :                    / ---------------------------
-	------------------------ \____, o          ,' ------------------------
+--------------------------- \____, o          ,' ----------------------------
-	------------------------- '--,___________,'  -------------------------
+---------------------------- '--,___________,'  -----------------------------
+
 -- Simple web server, publishing the outside host's /var/www
 webserver :: Docker.Container
 webserver = standardStableContainer "webserver"
@@ -434,13 +437,12 @@ dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch
 dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch
 dockerImage _ = "debian-stable-official" -- does not currently exist!
 
-myDnsSecondary :: Property
+myDnsSecondary :: Property HasInfo
-myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp
+myDnsSecondary = propertyList "dns secondary for all my domains" $ props
-	[ Dns.secondary hosts "kitenet.net"
+	& Dns.secondary hosts "kitenet.net"
-	, Dns.secondary hosts "joeyh.name"
+	& Dns.secondary hosts "joeyh.name"
-	, Dns.secondary hosts "ikiwiki.info"
+	& Dns.secondary hosts "ikiwiki.info"
-	, Dns.secondary hosts "olduse.net"
+	& Dns.secondary hosts "olduse.net"
-	]
 
 branchableSecondary :: RevertableProperty
 branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"
@@ -456,23 +458,11 @@ myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly No
 	, (RootDomain, NS $ AbsDomain "ns4.kitenet.net")
 	, (RootDomain, NS $ AbsDomain "ns6.gandi.net")
 	, (RootDomain, MX 0 $ AbsDomain "kitenet.net")
-	-- SPF only allows IP address of kitenet.net to send mail.
+	, (RootDomain, TXT "v=spf1 a a:kitenet.net ~all")
-	, (RootDomain, TXT "v=spf1 a:kitenet.net -all")
 	, JoeySites.domainKey
 	] ++ extras
 
 
-                          --                                o
-                          --             ___                 o              o
-                       {-----\          / o \              ___o            o
-                       {      \    __   \   /   _        (X___>--         __o
-  _____________________{ ______\___  \__/ | \__/ \____                  |X__>
- <                                  \___//|\\___/\     \____________   _
-  \                                  ___/ | \___    # #             \ (-)
-   \    O      O      O             #     |     \ #                  >=)
-    \______________________________# #   /       #__________________/ (-}
-
-
 monsters :: [Host]    -- Systems I don't manage with propellor,
 monsters =            -- but do want to track their public keys etc.
 	[ host "usw-s002.rsync.net"
@@ -508,3 +498,17 @@ monsters =            -- but do want to track their public keys etc.
 		& ipv4 "76.7.162.101"
 		& ipv4 "76.7.162.186"
 	]
+
+
+
+                          --                                o
+                          --             ___                 o              o
+                       {-----\          / o \              ___o            o
+                       {      \    __   \   /   _        (X___>--         __o
+  _____________________{ ______\___  \__/ | \__/ \____                  |X__>
+ <                                  \___//|\\___/\     \____________   _
+  \                                  ___/ | \___    # #             \ (-)
+   \    O      O      O             #     |     \ #                  >=)
+    \______________________________# #   /       #__________________/ (-}
+
+

debian/changelog

@@ -1,3 +1,31 @@
+propellor (2.0.0) UNRELEASED; urgency=medium
+
+  * Property has been converted to a GADT, and will be Property NoInfo
+    or Property HasInfo.
+    This was done to make sure that ensureProperty is only used on
+    properties that do not have Info.
+    Transition guide:
+    - Change all "Property" to "Property NoInfo" or "Property WithInfo"
+      (The compiler can tell you if you got it wrong!)
+    - To construct a RevertableProperty, it is useful to use the new
+      (<!>) operator
+    - Constructing a list of properties can be problimatic, since
+      Property NoInto and Property WithInfo are different types and cannot
+      appear in the same list. To deal with this, "props" has been added,
+      and can built up a list of properties of different types,
+      using the same (&) and (!) operators that are used to build
+      up a host's properties.
+  * Add descriptions of how to set missing fields to --list-fields output.
+  * Properties now form a tree, instead of the flat list used before.
+    This includes the properties used inside a container.
+  * Fix info propigation from fallback combinator's second Property.
+  * Added systemd configuration properties.
+  * Added journald configuration properties.
+  * Added more network interface configuration properties.
+  * Implemented OS.preserveNetwork.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 15 Jan 2015 20:14:29 -0400
+
 propellor (1.3.2) unstable; urgency=medium
 
   * SSHFP records are also generated for CNAMES of hosts.

debian/control

@@ -18,7 +18,7 @@ Build-Depends:
 	libghc-monadcatchio-transformers-dev,
 Maintainer: Gergely Nagy <algernon@madhouse-project.org>
 Standards-Version: 3.9.6
-Vcs-Git: git://git.kitenet.net/propellor
+Vcs-Git: git://git.joeyh.name/propellor
 Homepage: http://propellor.branchable.com/
 
 Package: propellor

doc/todo/RevertableProperty_with_NoInfo.mdwn

@@ -0,0 +1,29 @@
+Currently, a RevertableProperty's Properties always both HasInfo. This
+means that if a Property NoInfo is updated to be a RevertableProperty, and
+someplace called ensureProperty on it, that will refuse to compile.
+
+The workaround is generally to export the original NoInfo property under
+a different name, so it can still be used with ensureProperty.
+
+This could be fixed:
+
+	data RevertableProperty i1 i2 where
+		RProp :: Property i1 -> Property i2 -> RevertableProperty i1 i2
+
+However, needing to write "RevertableProperty HasInfo NoInfo" is quite
+a mouthful!
+
+Since only 2 places in the propellor source code currently need to deal
+with this, it doesn't currently seem worth making the change, unless a less
+intrusive way can be found.
+
+Probably related would be to make RevertableProperty a constructor in the
+Property GADT, which would allow more property combinators to work on
+RevertableProperties. That would look like:
+
+	data Propety i where
+		...
+		RProp :: Property i1 -> Property i2 -> Property (CInfo i1 i2)
+
+In this case, there's only one Info/NoInfo encompassing both sides, and
+so ensureProperty could only be used on it if both sides were NoInfo.

doc/todo/info_propigation_out_of_nested_properties.mdwn

@@ -1,3 +1,5 @@
+> Now [[fixed|done]]!! --[[Joey]]
+
 Currently, Info about a Host's Properties is propigated to the host by
 examining the tree of Properties.
 

propellor.cabal

@@ -85,6 +85,7 @@ Library
     Propellor.Property.Gpg
     Propellor.Property.Group
     Propellor.Property.Grub
+    Propellor.Property.Journald
     Propellor.Property.Mount
     Propellor.Property.Network
     Propellor.Property.Nginx
@@ -94,6 +95,7 @@ Library
     Propellor.Property.Postfix
     Propellor.Property.Prosody
     Propellor.Property.Reboot
+    Propellor.Property.List
     Propellor.Property.Scheduled
     Propellor.Property.Service
     Propellor.Property.Ssh
@@ -108,7 +110,7 @@ Library
     Propellor.Property.SiteSpecific.GitHome
     Propellor.Property.SiteSpecific.JoeySites
     Propellor.Property.SiteSpecific.GitAnnexBuilder
-    Propellor.Host
+    Propellor.PropAccum
     Propellor.CmdLine
     Propellor.Info
     Propellor.Message
@@ -122,6 +124,9 @@ Library
     Propellor.Types.Empty
     Propellor.Types.OS
     Propellor.Types.PrivData
+    Propellor.Types.Val
+    Propellor.Types.Result
+    Propellor.Types.CmdLine
   Other-Modules:
     Propellor.Git
     Propellor.Gpg
@@ -133,11 +138,13 @@ Library
     Propellor.Property.Chroot.Util
     Utility.Applicative
     Utility.Data
+    Utility.DataUnits
     Utility.Directory
     Utility.Env
     Utility.Exception
     Utility.FileMode
     Utility.FileSystemEncoding
+    Utility.HumanNumber
     Utility.LinuxMkLibs
     Utility.Misc
     Utility.Monad

src/Propellor.hs

@@ -27,13 +27,14 @@
 --
 -- See config.hs for a more complete example, and clone Propellor's
 -- git repository for a deployable system using Propellor:
--- git clone <git://git.kitenet.net/propellor>
+-- git clone <git://git.joeyh.name/propellor>
 
 module Propellor (
 	  module Propellor.Types
 	, module Propellor.Property
+	, module Propellor.Property.List
 	, module Propellor.Property.Cmd
-	, module Propellor.Host
+	, module Propellor.PropAccum
 	, module Propellor.Info
 	, module Propellor.PrivData
 	, module Propellor.Types.PrivData
@@ -48,13 +49,14 @@ module Propellor (
 import Propellor.Types
 import Propellor.Property
 import Propellor.Engine
+import Propellor.Property.List
 import Propellor.Property.Cmd
 import Propellor.PrivData
 import Propellor.Types.PrivData
 import Propellor.Message
 import Propellor.Exception
 import Propellor.Info
-import Propellor.Host
+import Propellor.PropAccum
 
 import Utility.PartialPrelude as X
 import Utility.Process as X

src/Propellor/CmdLine.hs

@@ -13,6 +13,7 @@ import Propellor
 import Propellor.Gpg
 import Propellor.Git
 import Propellor.Spin
+import Propellor.Types.CmdLine
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Shim as Shim

src/Propellor/Engine.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GADTs #-}
 
 module Propellor.Engine (
 	mainProperties,
@@ -35,7 +36,7 @@ import Utility.Monad
 mainProperties :: Host -> IO ()
 mainProperties host = do
 	ret <- runPropellor host $
-		ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
+		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
 	h <- mkMessageHandle
         whenConsole h $
 		setTitle "propellor: done"
@@ -43,6 +44,8 @@ mainProperties host = do
 	case ret of
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
+  where
+	ps = map ignoreInfo $ hostProperties host
 
 -- | Runs a Propellor action with the specified host.
 --
@@ -62,11 +65,13 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
 
 -- | For when code running in the Propellor monad needs to ensure a
 -- Property.
-ensureProperty :: Property -> Propellor Result
+--
+-- This can only be used on a Property that has NoInfo.
+ensureProperty :: Property NoInfo -> Propellor Result
 ensureProperty = catchPropellor . propertySatisfy
 
 -- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property] -> Propellor Result
+ensureProperties :: [Property NoInfo] -> Propellor Result
 ensureProperties ps = ensure ps NoChange
   where
 	ensure [] rs = return rs
@@ -77,7 +82,7 @@ ensureProperties ps = ensure ps NoChange
 
 -- | Lifts an action into a different host.
 --
--- For example, `fromHost hosts "otherhost" getPubKey`
+-- > fromHost hosts "otherhost" getPubKey
 fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
 fromHost l hn getter = case findHost l hn of
 	Nothing -> return Nothing

src/Propellor/Host.hs

@@ -1,64 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Host where
-
-import Data.Monoid
-import qualified Data.Set as S
-
-import Propellor.Types
-import Propellor.Info
-import Propellor.Property
-import Propellor.PrivData
-
--- | Starts accumulating the properties of a Host.
---
--- > host "example.com"
--- > 	& someproperty
--- > 	! oldproperty
--- > 	& otherproperty
-host :: HostName -> Host
-host hn = Host hn [] mempty
-
--- | Something that can accumulate properties.
-class Hostlike h where
-	-- | Adds a property.
-	--
-	-- Can add Properties and RevertableProperties
-	(&) :: IsProp p => h -> p -> h
-
-	-- | Like (&), but adds the property as the
-	-- first property of the host. Normally, property
-	-- order should not matter, but this is useful
-	-- when it does.
-	(&^) :: IsProp p => h -> p -> h
-
-	getHost :: h -> Host
-
-instance Hostlike Host where
-	(Host hn ps is) &  p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
-	(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
-	getHost h = h
-
--- | Adds a property in reverted form.
-(!) :: Hostlike h => h -> RevertableProperty -> h
-h ! p = h & revert p
-
-infixl 1 &^
-infixl 1 &
-infixl 1 !
-
--- | When eg, docking a container, some of the Info about the container
--- should propigate out to the Host it's on. This includes DNS info,
--- so that eg, aliases of the container are reflected in the dns for the
--- host where it runs.
---
--- This adjusts the Property that docks a container, to include such info
--- from the container.
-propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property
-propigateInfo hl p f = combineProperties (propertyDesc p) $
-	p' : dnsprops ++ privprops
-  where
-	p' = p { propertyInfo = f (propertyInfo p) }
-	i = hostInfo (getHost hl)
-	dnsprops = map addDNS (S.toList $ _dns i)
-	privprops = map addPrivDataField (S.toList $ _privDataFields i)

src/Propellor/Info.hs

@@ -3,6 +3,7 @@
 module Propellor.Info where
 
 import Propellor.Types
+import Propellor.Types.Val
 
 import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
@@ -11,13 +12,13 @@ import Data.Maybe
 import Data.Monoid
 import Control.Applicative
 
-pureInfoProperty :: Desc -> Info -> Property 
+pureInfoProperty :: Desc -> Info -> Property HasInfo
-pureInfoProperty desc = Property ("has " ++ desc) (return NoChange)
+pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
 
 askInfo :: (Info -> Val a) -> Propellor (Maybe a)
 askInfo f = asks (fromVal . f . hostInfo)
 
-os :: System -> Property
+os :: System -> Property HasInfo
 os system = pureInfoProperty ("Operating " ++ show system) $
 	mempty { _os = Val system }
 
@@ -33,11 +34,11 @@ getOS = askInfo _os
 -- When propellor --spin is used to deploy a host, it checks
 -- if the host's IP Property matches the DNS. If the DNS is missing or
 -- out of date, the host will instead be contacted directly by IP address.
-ipv4 :: String -> Property
+ipv4 :: String -> Property HasInfo
 ipv4 = addDNS . Address . IPv4
 
 -- | Indidate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property
+ipv6 :: String -> Property HasInfo
 ipv6 = addDNS . Address . IPv6
 
 -- | Indicates another name for the host in the DNS.
@@ -46,7 +47,7 @@ ipv6 = addDNS . Address . IPv6
 -- to use their address, rather than using a CNAME. This avoids various
 -- problems with CNAMEs, and also means that when multiple hosts have the
 -- same alias, a DNS round-robin is automatically set up.
-alias :: Domain -> Property
+alias :: Domain -> Property HasInfo
 alias d = pureInfoProperty ("alias " ++ d) $ mempty
 	{ _aliases = S.singleton d
 	-- A CNAME is added here, but the DNS setup code converts it to an
@@ -54,7 +55,7 @@ alias d = pureInfoProperty ("alias " ++ d) $ mempty
 	, _dns = S.singleton $ CNAME $ AbsDomain d
 	} 
 
-addDNS :: Record -> Property
+addDNS :: Record -> Property HasInfo
 addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
   where
 	rdesc (CNAME d) = unwords ["alias", ddesc d]

src/Propellor/PrivData.hs

@@ -1,6 +1,19 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE FlexibleContexts #-}
 
-module Propellor.PrivData where
+module Propellor.PrivData (
+	withPrivData,
+	withSomePrivData,
+	addPrivData,
+	setPrivData,
+	dumpPrivData,
+	editPrivData,
+	filterPrivData,
+	listPrivDataFields,
+	makePrivDataDir,
+	decryptPrivData,
+	PrivMap,
+) where
 
 import Control.Applicative
 import System.IO
@@ -48,29 +61,29 @@ import Utility.Table
 -- being used, which is necessary to ensure that the privdata is sent to
 -- the remote host by propellor.
 withPrivData
-	:: (IsContext c, IsPrivDataSource s)
+	:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
 	=> s
 	-> c
-	-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property)
+	-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)
-	-> Property
+	-> Property HasInfo
 withPrivData s = withPrivData' snd [s]
 
 -- Like withPrivData, but here any one of a list of PrivDataFields can be used.
 withSomePrivData
-	:: (IsContext c, IsPrivDataSource s)
+	:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
 	=> [s]
 	-> c
-	-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property)
+	-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)
-	-> Property
+	-> Property HasInfo
 withSomePrivData = withPrivData' id
 
 withPrivData' 
-	:: (IsContext c, IsPrivDataSource s)
+	:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
 	=> ((PrivDataField, PrivData) -> v)
 	-> [s]
 	-> c
-	-> (((v -> Propellor Result) -> Propellor Result) -> Property)
+	-> (((v -> Propellor Result) -> Propellor Result) -> Property i)
-	-> Property
+	-> Property HasInfo
 withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 	maybe missing (a . feed) =<< getM get fieldlist
   where
@@ -82,20 +95,28 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 		Context cname <- mkHostContext hc <$> asks hostName
 		warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")"
 		liftIO $ putStrLn $ "Fix this by running:"
-		liftIO $ forM_ srclist $ \src -> do
+		liftIO $ showSet $
-			putStrLn $ "  propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "' \\"
+			map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
-			maybe noop (\d -> putStrLn $ "    " ++ d) (describePrivDataSource src)
-			putStrLn ""
 		return FailedChange
-	addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = fieldset } }
+	addinfo p = infoProperty
+		(propertyDesc p)
+		(propertySatisfy p)
+		(propertyInfo p <> mempty { _privData = privset })
+		(propertyChildren p)
+	privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
 	fieldnames = map show fieldlist
-	fieldset = S.fromList $ zip fieldlist (repeat hc)
 	fieldlist = map privDataField srclist
 	hc = asHostContext c
 
-addPrivDataField :: (PrivDataField, HostContext) -> Property
+showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO ()
-addPrivDataField v = pureInfoProperty (show v) $
+showSet l = forM_ l $ \(f, Context c, md) -> do
-	mempty { _privDataFields = S.singleton v }
+	putStrLn $ "  propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"
+	maybe noop (\d -> putStrLn $ "    " ++ d) md
+	putStrLn ""
+
+addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
+addPrivData v = pureInfoProperty (show v) $
+	mempty { _privData = S.singleton v }
 
 {- Gets the requested field's value, in the specified context if it's
  - available, from the host's local privdata cache. -}
@@ -107,12 +128,12 @@ getLocalPrivData field context =
 
 type PrivMap = M.Map (PrivDataField, Context) PrivData
 
-{- Get only the set of PrivData that the Host's Info says it uses. -}
+-- | Get only the set of PrivData that the Host's Info says it uses.
 filterPrivData :: Host -> PrivMap -> PrivMap
 filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
   where
-	used = S.map (\(f, c) -> (f, mkHostContext c (hostName host))) $
+	used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
-		_privDataFields $ hostInfo host
+		_privData $ hostInfo host
 
 getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
 getPrivData field context = M.lookup (field, context)
@@ -142,10 +163,17 @@ editPrivData field context = do
 listPrivDataFields :: [Host] -> IO ()
 listPrivDataFields hosts = do
 	m <- decryptPrivData
-	showtable "Currently set data:" $
+	
-		map mkrow (M.keys m)
+	section "Currently set data:"
-	showtable "Data that would be used if set:" $
+	showtable $ map mkrow (M.keys m)
-		map mkrow (M.keys $ M.difference wantedmap m)
+	let missing = M.keys $ M.difference wantedmap m
+	
+	unless (null missing) $ do
+		section "Missing data that would be used if set:"
+		showtable $ map mkrow missing
+
+		section "How to set missing data:"
+		showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
   where
 	header = ["Field", "Context", "Used by"]
 	mkrow k@(field, (Context context)) =
@@ -153,12 +181,13 @@ listPrivDataFields hosts = do
 		, shellEscape context
 		, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
 		]
-	mkhostmap host = M.fromList $ map (\(f, c) -> ((f, mkHostContext c (hostName host)), [hostName host])) $
+	mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $
-		S.toList $ _privDataFields $ hostInfo host
+		S.toList $ _privData $ hostInfo host
-	usedby = M.unionsWith (++) $ map mkhostmap hosts
+	usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts
 	wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")
-	showtable desc rows = do
+	descmap = M.unions $ map (\h -> mkhostmap h id) hosts
-		putStrLn $ "\n" ++ desc
+	section desc = putStrLn $ "\n" ++ desc
+	showtable rows = do
 		putStr $ unlines $ formatTable $ tableWithHeader header rows
 
 setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()

src/Propellor/PropAccum.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.PropAccum where
+
+import Data.Monoid
+
+import Propellor.Types
+import Propellor.Property
+
+-- | Starts accumulating the properties of a Host.
+--
+-- > host "example.com"
+-- > 	& someproperty
+-- > 	! oldproperty
+-- > 	& otherproperty
+host :: HostName -> Host
+host hn = Host hn [] mempty
+
+-- | Starts accumulating a list of properties.
+--
+-- > propertyList "foo" $ props
+-- > 	& someproperty
+-- > 	! oldproperty
+-- > 	& otherproperty
+props :: PropList
+props = PropList []
+
+-- | Something that can accumulate properties.
+class PropAccum h where
+	-- | Adds a property.
+	--
+	-- Can add Properties and RevertableProperties
+	(&) :: IsProp p => h -> p -> h
+
+	-- | Like (&), but adds the property at the front of the list.
+	(&^) :: IsProp p => h -> p -> h
+
+	getProperties :: h -> [Property HasInfo]
+
+instance PropAccum Host where
+	(Host hn ps is) &  p = Host hn (ps ++ [toProp p])
+		(is <> getInfoRecursive p)
+	(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps)
+		(getInfoRecursive p <> is)
+	getProperties = hostProperties
+
+data PropList = PropList [Property HasInfo]
+
+instance PropAccum PropList where
+	PropList l &  p = PropList (l ++ [toProp p])
+	PropList l &^ p = PropList ([toProp p] ++ l)
+	getProperties (PropList l) = l
+
+-- | Adds a property in reverted form.
+(!) :: PropAccum h => h -> RevertableProperty -> h
+h ! p = h & revert p
+
+infixl 1 &^
+infixl 1 &
+infixl 1 !
+
+-- | Adjust the provided Property, adding to its
+-- propertyChidren the properties of the provided container.
+-- 
+-- The Info of the propertyChildren is adjusted to only include 
+-- info that should be propigated out to the Property.
+--
+-- DNS Info is propigated, so that eg, aliases of a PropAccum
+-- are reflected in the dns for the host where it runs.
+--
+-- PrivData Info is propigated, so that properties used inside a
+-- PropAccum will have the necessary PrivData available.
+propigateContainer
+	:: (PropAccum container)
+	=> container
+	-> Property HasInfo
+	-> Property HasInfo
+propigateContainer c prop = infoProperty
+	(propertyDesc prop)
+	(propertySatisfy prop)
+	(propertyInfo prop)
+	(propertyChildren prop ++ hostprops)
+  where
+	hostprops = map go $ getProperties c
+	go p = 
+		let i = propertyInfo p
+		    i' = mempty
+			{ _dns = _dns i
+			, _privData = _privData i
+			}
+		    cs = map go (propertyChildren p)
+		in infoProperty (propertyDesc p) (propertySatisfy p) i' cs

src/Propellor/Property.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Propellor.Property where
 
@@ -11,47 +12,21 @@ import "mtl" Control.Monad.RWS.Strict
 
 import Propellor.Types
 import Propellor.Info
-import Propellor.Engine
 import Utility.Monad
 
--- Constructs a Property.
+-- | Constructs a Property, from a description and an action to run to
-property :: Desc -> Propellor Result -> Property
+-- ensure the Property is met.
-property d s = Property d s mempty
+property :: Desc -> Propellor Result -> Property NoInfo
-
+property d s = simpleProperty d s mempty
--- | Combines a list of properties, resulting in a single property
--- that when run will run each property in the list in turn,
--- 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) (combineInfos ps)
-
--- | Combines a list of properties, resulting in one property that
--- ensures each in turn. Stops if a property fails.
-combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps)
-  where
-	go [] rs = return rs
-	go (l:ls) rs = do
-		r <- ensureProperty l
-		case r of
-			FailedChange -> return FailedChange
-			_ -> go ls (r <> rs)
-
--- | Combines together two properties, resulting in one property
--- 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 = p2 `requires` p1
-	`describe` (propertyDesc p1)
 
 -- | Makes a perhaps non-idempotent Property be idempotent by using a flag
 -- file to indicate whether it has run before.
 -- Use with caution.
-flagFile :: Property -> FilePath -> Property
+flagFile :: Property i -> FilePath -> Property i
 flagFile p = flagFile' p . return
 
-flagFile' :: Property -> IO FilePath -> Property
+flagFile' :: Property i -> IO FilePath -> Property i
-flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
+flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
 	flagfile <- liftIO getflagfile
 	go satisfy flagfile =<< liftIO (doesFileExist flagfile)
   where
@@ -64,37 +39,40 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
 				writeFile flagfile ""
 		return r
 
---- | Whenever a change has to be made for a Property, causes a hook
+-- | 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
+onChange
-p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook)
+	:: (Combines (Property x) (Property y))
-  where
+	=> Property x
-	satisfy = do
+        -> Property y
-		r <- ensureProperty p
+        -> CombinedType (Property x) (Property y)
-		case r of
+onChange = combineWith $ \p hook -> do
-			MadeChange -> do
+	r <- p
-				r' <- ensureProperty hook
+	case r of
-				return $ r <> r'
+		MadeChange -> do
-			_ -> return r
+			r' <- hook
+			return $ r <> r'
+		_ -> return r
 
-(==>) :: Desc -> Property -> Property
+-- | Alias for @flip describe@
+(==>) :: IsProp (Property i) => Desc -> Property i -> Property i
 (==>) = flip describe
 infixl 1 ==>
 
 -- | Makes a Property only need to do anything when a test succeeds.
-check :: IO Bool -> Property -> Property
+check :: IO Bool -> Property i -> Property i
-check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
+check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c)
 	( satisfy
 	, return NoChange
 	)
 
 -- | Tries the first property, but if it fails to work, instead uses
 -- the second.
-fallback :: Property -> Property -> Property
+fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2)
-fallback p1 p2 = adjustProperty p1 $ \satisfy -> do
+fallback = combineWith $ \a1 a2 -> do
-	r <- satisfy
+	r <- a1
 	if r == FailedChange
-		then propertySatisfy p2
+		then a2
 		else return r
 
 -- | Marks a Property as trivial. It can only return FailedChange or
@@ -103,44 +81,33 @@ fallback p1 p2 = adjustProperty p1 $ \satisfy -> do
 -- Useful when it's just as expensive to check if a change needs
 -- to be made as it is to just idempotently assure the property is
 -- satisfied. For example, chmodding a file.
-trivial :: Property -> Property
+trivial :: Property i -> Property i
-trivial p = adjustProperty p $ \satisfy -> do
+trivial p = adjustPropertySatisfy p $ \satisfy -> do
 	r <- satisfy
 	if r == MadeChange
 		then return NoChange
 		else return r
 
-doNothing :: Property
-doNothing = property "noop property" noChange
-
 -- | Makes a property that is satisfied differently depending on the host's
 -- operating system. 
 --
 -- Note that the operating system may not be declared for some hosts.
-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
+withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
 withOS desc a = property desc $ a =<< getOS
 
 -- | Undoes the effect of a property.
 revert :: RevertableProperty -> RevertableProperty
 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
 
--- | Changes the action that is performed to satisfy a property. 
-adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
-adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
-
--- | Combines the Info of two properties.
-combineInfo :: (IsProp p, IsProp q) => p -> q -> Info
-combineInfo p q = getInfo p <> getInfo q
-
-combineInfos :: IsProp p => [p] -> Info
-combineInfos = mconcat . map getInfo
-
 makeChange :: IO () -> Propellor Result
 makeChange a = liftIO a >> return MadeChange
 
 noChange :: Propellor Result
 noChange = return NoChange
 
+doNothing :: Property NoInfo
+doNothing = property "noop property" noChange
+
 -- | Registers an action that should be run at the very end,
 endAction :: Desc -> (Result -> Propellor Result) -> Propellor ()
 endAction desc a = tell [EndAction desc a]

src/Propellor/Property/Apache.hs

@@ -9,7 +9,7 @@ import Utility.SafeCommand
 type ConfigFile = [String]
 
 siteEnabled :: HostName -> ConfigFile -> RevertableProperty
-siteEnabled hn cf = RevertableProperty enable disable
+siteEnabled hn cf = enable <!> disable
   where
 	enable = combineProperties ("apache site enabled " ++ hn)
 		[ siteAvailable hn cf
@@ -28,14 +28,14 @@ siteEnabled hn cf = RevertableProperty enable disable
 		`onChange` reloaded
 	isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn]
 
-siteAvailable :: HostName -> ConfigFile -> Property
+siteAvailable :: HostName -> ConfigFile -> Property NoInfo
 siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $
 	map (`File.hasContent` (comment:cf)) (siteCfg hn)
   where
 	comment = "# deployed with propellor, do not modify"
 
 modEnabled :: String -> RevertableProperty
-modEnabled modname = RevertableProperty enable disable
+modEnabled modname = enable <!> disable
   where
 	enable = check (not <$> isenabled) $
 		cmdProperty "a2enmod" ["--quiet", modname]
@@ -59,18 +59,18 @@ siteCfg hn =
 	, "/etc/apache2/sites-available/" ++ hn ++ ".conf"
 	] 
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["apache2"]
 
-restarted :: Property
+restarted :: Property NoInfo
 restarted = Service.restarted "apache2"
 
-reloaded :: Property
+reloaded :: Property NoInfo
 reloaded = Service.reloaded "apache2"
 
 -- | Configure apache to use SNI to differentiate between
 -- https hosts.
-multiSSL :: Property
+multiSSL :: Property NoInfo
 multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`
 	[ "NameVirtualHost *:443"
 	, "SSLStrictSNIVHostCheck off"

src/Propellor/Property/Apt.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Propellor.Property.Apt where
 
 import Data.Maybe
@@ -77,36 +79,36 @@ securityUpdates suite
 --
 -- Since the CDN is sometimes unreliable, also adds backup lines using
 -- kernel.org.
-stdSourcesList :: Property
+stdSourcesList :: Property NoInfo
 stdSourcesList = withOS ("standard sources.list") $ \o ->
 	case o of
 		(Just (System (Debian suite) _)) ->
 			ensureProperty $ stdSourcesListFor suite
 		_ -> error "os is not declared to be Debian"
 
-stdSourcesListFor :: DebianSuite -> Property
+stdSourcesListFor :: DebianSuite -> Property NoInfo
 stdSourcesListFor suite = stdSourcesList' suite []
 
 -- | Adds additional sources.list generators.
 --
 -- Note that if a Property needs to enable an apt source, it's better
 -- to do so via a separate file in </etc/apt/sources.list.d/>
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property
+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
 stdSourcesList' suite more = setSourcesList
 	(concatMap (\gen -> gen suite) generators)
 	`describe` ("standard sources.list for " ++ show suite)
   where
 	generators = [debCdn, kernelOrg, securityUpdates] ++ more
 
-setSourcesList :: [Line] -> Property
+setSourcesList :: [Line] -> Property NoInfo
 setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
 
-setSourcesListD :: [Line] -> FilePath -> Property
+setSourcesListD :: [Line] -> FilePath -> Property NoInfo
 setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
   where
 	f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
 
-runApt :: [String] -> Property
+runApt :: [String] -> Property NoInfo
 runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv
 
 noninteractiveEnv :: [(String, String)]
@@ -115,26 +117,26 @@ noninteractiveEnv =
 		, ("APT_LISTCHANGES_FRONTEND", "none")
 		]
 
-update :: Property
+update :: Property NoInfo
 update = runApt ["update"]
 	`describe` "apt update"
 
-upgrade :: Property
+upgrade :: Property NoInfo
 upgrade = runApt ["-y", "dist-upgrade"]
 	`describe` "apt dist-upgrade"
 
 type Package = String
 
-installed :: [Package] -> Property
+installed :: [Package] -> Property NoInfo
 installed = installed' ["-y"]
 
-installed' :: [String] -> [Package] -> Property
+installed' :: [String] -> [Package] -> Property NoInfo
 installed' params ps = robustly $ check (isInstallable ps) go
 	`describe` (unwords $ "apt installed":ps)
   where
 	go = runApt $ params ++ ["install"] ++ ps
 
-installedBackport :: [Package] -> Property
+installedBackport :: [Package] -> Property NoInfo
 installedBackport ps = trivial $ withOS desc $ \o -> case o of
 	Nothing -> error "cannot install backports; os not declared"
 	(Just (System (Debian suite) _)) -> case backportSuite suite of
@@ -147,16 +149,16 @@ installedBackport ps = trivial $ withOS desc $ \o -> case o of
 	notsupported o = error $ "backports not supported on " ++ show o
 
 -- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property
+installedMin :: [Package] -> Property NoInfo
 installedMin = installed' ["--no-install-recommends", "-y"]
 
-removed :: [Package] -> Property
+removed :: [Package] -> Property NoInfo
 removed ps = check (or <$> isInstalled' ps) go
 	`describe` (unwords $ "apt removed":ps)
   where
 	go = runApt $ ["-y", "remove"] ++ ps
 
-buildDep :: [Package] -> Property
+buildDep :: [Package] -> Property NoInfo
 buildDep ps = robustly go
 	`describe` (unwords $ "apt build-dep":ps)
   where
@@ -165,7 +167,7 @@ buildDep ps = robustly go
 -- | Installs the build deps for the source package unpacked
 -- in the specifed directory, with a dummy package also
 -- installed so that autoRemove won't remove them.
-buildDepIn :: FilePath -> Property
+buildDepIn :: FilePath -> Property NoInfo
 buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
   where
 	go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]
@@ -173,11 +175,13 @@ 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 :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
-robustly p = adjustProperty p $ \satisfy -> do
+robustly p = adjustPropertySatisfy p $ \satisfy -> do
 	r <- satisfy
 	if r == FailedChange
-		then ensureProperty $ p `requires` update
+		-- Safe to use ignoreInfo because we're re-running
+		-- the same property.
+		then ensureProperty $ ignoreInfo $ p `requires` update
 		else return r
 
 isInstallable :: [Package] -> IO Bool
@@ -203,13 +207,13 @@ isInstalled' ps = catMaybes . map parse . lines <$> policy
 		environ <- addEntry "LANG" "C" <$> getEnvironment
 		readProcessEnv "apt-cache" ("policy":ps) (Just environ)
 
-autoRemove :: Property
+autoRemove :: Property NoInfo
 autoRemove = runApt ["-y", "autoremove"]
 	`describe` "apt autoremove"
 
 -- | Enables unattended upgrades. Revert to disable.
 unattendedUpgrades :: RevertableProperty
-unattendedUpgrades = RevertableProperty enable disable
+unattendedUpgrades = enable <!> disable
   where
 	enable = setup True
 		`before` Service.running "cron"
@@ -237,7 +241,7 @@ unattendedUpgrades = RevertableProperty enable disable
 
 -- | Preseeds debconf values and reconfigures the package so it takes
 -- effect.
-reConfigure :: Package -> [(String, String, String)] -> Property
+reConfigure :: Package -> [(String, String, String)] -> Property NoInfo
 reConfigure package vals = reconfigure `requires` setselections
 	`describe` ("reconfigure " ++ package)
   where
@@ -253,7 +257,7 @@ reConfigure package vals = reconfigure `requires` setselections
 --
 -- Assumes that there is a 1:1 mapping between service names and apt
 -- package names.
-serviceInstalledRunning :: Package -> Property
+serviceInstalledRunning :: Package -> Property NoInfo
 serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
 
 data AptKey = AptKey
@@ -262,20 +266,27 @@ data AptKey = AptKey
 	}
 
 trustsKey :: AptKey -> RevertableProperty
-trustsKey k = RevertableProperty trust untrust
+trustsKey k = trustsKey' k <!> untrustKey k
+
+trustsKey' :: AptKey -> Property NoInfo
+trustsKey' k = 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)
+			hClose h
+	nukeFile $ f ++ "~" -- gpg dropping
   where
 	desc = "apt trusts key " ++ keyname k
-	f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
+	f = aptKeyFile k
-	untrust = File.notPresent f
+
-	trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
+untrustKey :: AptKey -> Property NoInfo
-		withHandle StdinHandle createProcessSuccess
+untrustKey = File.notPresent . aptKeyFile
-			(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
+
-				hPutStr h (pubkey k)
+aptKeyFile :: AptKey -> FilePath
-				hClose h
+aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-		nukeFile $ f ++ "~" -- gpg dropping
 
 -- | Cleans apt's cache of downloaded packages to avoid using up disk
 -- space.
-cacheCleaned :: Property
+cacheCleaned :: Property NoInfo
 cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"]
 	`describe` "apt cache cleaned"

src/Propellor/Property/Chroot.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Propellor.Property.Chroot (
 	Chroot(..),
+	BuilderConf(..),
 	debootstrapped,
 	provisioned,
 	-- * Internal use
@@ -10,6 +13,7 @@ module Propellor.Property.Chroot (
 ) where
 
 import Propellor
+import Propellor.Types.CmdLine
 import Propellor.Types.Chroot
 import Propellor.Property.Chroot.Util
 import qualified Propellor.Property.Debootstrap as Debootstrap
@@ -28,10 +32,10 @@ data BuilderConf
 	= UsingDeboostrap Debootstrap.DebootstrapConfig
 	deriving (Show)
 
-instance Hostlike Chroot where
+instance PropAccum Chroot where
 	(Chroot l s c h) & p = Chroot l s c (h & p)
 	(Chroot l s c h) &^ p = Chroot l s c (h &^ p)
-	getHost (Chroot _ _ _ h) = h
+	getProperties (Chroot _ _ _ h) = hostProperties h
 
 -- | Defines a Chroot at the given location, built with debootstrap.
 --
@@ -57,12 +61,13 @@ debootstrapped system conf location = case system of
 provisioned :: Chroot -> RevertableProperty
 provisioned c = provisioned' (propigateChrootInfo c) c False
 
-provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty
+provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
-provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty
+provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
 	(propigator $ go "exists" setup)
+		<!>
 	(go "removed" teardown)
   where
-	go desc a = property (chrootDesc c desc) $ ensureProperties [a]
+	go desc a = propertyList (chrootDesc c desc) [a]
 
 	setup = propellChroot c (inChrootProcess c) systemdonly
 		`requires` toProp built
@@ -75,15 +80,21 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert
 
 	teardown = toProp (revert built)
 
-propigateChrootInfo :: Chroot -> Property -> Property
+propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
-propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c)
+propigateChrootInfo c p = propigateContainer c p'
+  where
+	p' = infoProperty
+		(propertyDesc p)
+		(propertySatisfy p)
+		(propertyInfo p <> chrootInfo c)
+		(propertyChildren p)
 
 chrootInfo :: Chroot -> Info
 chrootInfo (Chroot loc _ _ h) =
 	mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
 
 -- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property
+propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo
 propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
 	let d = localdir </> shimdir c
 	let me = localdir </> "propellor"
@@ -140,7 +151,8 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 			r <- runPropellor h $ ensureProperties $
 				if systemdonly
 					then [Systemd.installed]
-					else hostProperties h
+					else map ignoreInfo $
+						hostProperties h
 			putStrLn $ "\n" ++ show r
 chain _ _ = errorMessage "bad chain command"
 

src/Propellor/Property/Cmd.hs

@@ -19,12 +19,12 @@ import Utility.Env
 -- | A property that can be satisfied by running a command.
 --
 -- The command must exit 0 on success.
-cmdProperty :: String -> [String] -> Property
+cmdProperty :: String -> [String] -> Property NoInfo
 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' :: String -> [String] -> [(String, String)] -> Property NoInfo
 cmdProperty' cmd params env = property desc $ liftIO $ do
 	env' <- addEntries env <$> getEnvironment
 	toResult <$> boolSystemEnv cmd (map Param params) (Just env')
@@ -32,14 +32,14 @@ cmdProperty' cmd params env = property desc $ liftIO $ do
 	desc = unwords $ cmd : params
 
 -- | A property that can be satisfied by running a series of shell commands.
-scriptProperty :: [String] -> Property
+scriptProperty :: [String] -> Property NoInfo
 scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
   where
 	shellcmd = intercalate " ; " ("set -e" : script)
 
 -- | A property that can satisfied by running a series of shell commands,
 -- as user (cd'd to their home directory).
-userScriptProperty :: UserName -> [String] -> Property
+userScriptProperty :: UserName -> [String] -> Property NoInfo
 userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]
   where
 	shellcmd = intercalate " ; " ("set -e" : "cd" : script)

src/Propellor/Property/Cron.hs

@@ -19,7 +19,7 @@ type CronTimes = String
 -- job file.
 --
 -- The cron job's output will only be emailed if it exits nonzero.
-job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
+job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo
 job desc times user cddir command = combineProperties ("cronned " ++ desc)
 	[ cronjobfile `File.hasContent`
 		[ "# Generated by propellor"
@@ -52,10 +52,10 @@ job desc times user cddir command = combineProperties ("cronned " ++ desc)
 		| otherwise = '_'
 
 -- | Installs a cron job, and runs it niced and ioniced.
-niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
+niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo
 niceJob desc times user cddir command = job desc times user cddir
 	("nice ionice -c 3 sh -c " ++ shellEscape command)
 
 -- | Installs a cron job to run propellor.
-runPropellor :: CronTimes -> Property
+runPropellor :: CronTimes -> Property NoInfo
 runPropellor times = niceJob "propellor" times "root" localdir "./propellor"

src/Propellor/Property/Debootstrap.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Propellor.Property.Debootstrap (
 	Url,
 	DebootstrapConfig(..),
@@ -56,19 +58,18 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
 -- Note that reverting this property does not stop any processes
 -- currently running in the chroot.
 built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty
-built = built' (toProp installed)
+built target system config = built' (toProp installed) target system config <!> teardown
-
-built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty
-built' installprop target system@(System _ arch) config =
-	RevertableProperty setup teardown
   where
-	setup = check (unpopulated target <||> ispartial) setupprop
-		`requires` installprop
-	
 	teardown = check (not <$> unpopulated target) teardownprop
 	
-	unpopulated d = null <$> catchDefaultIO [] (dirContents d)
+	teardownprop = property ("removed debootstrapped " ++ target) $
+		makeChange (removetarget target)
 
+built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
+built' installprop target system@(System _ arch) config = 
+	check (unpopulated target <||> ispartial) setupprop
+		`requires` installprop
+  where
 	setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
 		createDirectoryIfMissing True target
 		-- Don't allow non-root users to see inside the chroot,
@@ -93,24 +94,25 @@ built' installprop target system@(System _ arch) config =
 			, return FailedChange
 			)
 
-	teardownprop = property ("removed debootstrapped " ++ target) $
-		makeChange removetarget
-
-	removetarget = do
-		submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
-			. filter (dirContains target)
-			<$> mountPoints
-		forM_ submnts umountLazy
-		removeDirectoryRecursive target
-
 	-- A failed debootstrap run will leave a debootstrap directory;
 	-- recover by deleting it and trying again.
 	ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
 		( do
-			removetarget
+			removetarget target
 			return True
 		, return False
 		)
+	
+unpopulated :: FilePath -> IO Bool
+unpopulated d = null <$> catchDefaultIO [] (dirContents d)	
+
+removetarget :: FilePath -> IO ()
+removetarget target = do
+	submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
+		. filter (dirContains target)
+		<$> mountPoints
+	forM_ submnts umountLazy
+	removeDirectoryRecursive target
 
 extractSuite :: System -> Maybe String
 extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
@@ -122,7 +124,7 @@ extractSuite (System (Ubuntu r) _) = Just r
 -- Note that installation from source is done by downloading the tarball
 -- from a Debian mirror, with no cryptographic verification.
 installed :: RevertableProperty
-installed = RevertableProperty install remove
+installed = install <!> remove
   where
 	install = withOS "debootstrap installed" $ \o -> 
 		ifM (liftIO $ isJust <$> programPath)
@@ -142,18 +144,18 @@ installed = RevertableProperty install remove
 	aptinstall = Apt.installed ["debootstrap"]
 	aptremove = Apt.removed ["debootstrap"]
 
-sourceInstall :: Property
+sourceInstall :: Property NoInfo
 sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
 	`requires` perlInstalled
 	`requires` arInstalled
 
-perlInstalled :: Property
+perlInstalled :: Property NoInfo
 perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
 	liftIO $ toResult . isJust <$> firstM id
 		[ yumInstall "perl"
 		]
 
-arInstalled :: Property
+arInstalled :: Property NoInfo
 arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
 	liftIO $ toResult . isJust <$> firstM id
 		[ yumInstall "binutils"
@@ -197,7 +199,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
 				return MadeChange
 			_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
 
-sourceRemove :: Property
+sourceRemove :: Property NoInfo
 sourceRemove = property "debootstrap not installed from source" $ liftIO $
 	ifM (doesDirectoryExist sourceInstallDir)
 		( do

src/Propellor/Property/Dns.hs

@@ -58,7 +58,7 @@ import Data.List
 -- In either case, the secondary dns server Host should have an ipv4 and/or
 -- ipv6 property defined.
 primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
-primary hosts domain soa rs = RevertableProperty setup cleanup
+primary hosts domain soa rs = setup <!> cleanup
   where
 	setup = setupPrimary zonefile id hosts domain soa rs
 		`onChange` Service.reloaded "bind9"
@@ -67,7 +67,7 @@ primary hosts domain soa rs = RevertableProperty setup cleanup
 
 	zonefile = "/etc/bind/propellor/db." ++ domain
 
-setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property
+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo
 setupPrimary zonefile mknamedconffile hosts domain soa rs = 
 	withwarnings baseprop
 		`requires` servingZones
@@ -77,8 +77,8 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 	indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
 	
 	(partialzone, zonewarnings) = genZone indomain hostmap domain soa
-	baseprop = Property ("dns primary for " ++ domain) satisfy
+	baseprop = infoProperty ("dns primary for " ++ domain) satisfy
-		(addNamedConf conf)
+		(addNamedConf conf) []
 	satisfy = do
 		sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
 		let zone = partialzone
@@ -87,7 +87,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 			( makeChange $ writeZoneFile zone zonefile
 			, noChange
 			)
-	withwarnings p = adjustProperty p $ \a -> do
+	withwarnings p = adjustPropertySatisfy p $ \a -> do
 		mapM_ warningMessage $ zonewarnings ++ secondarywarnings
 		a
 	conf = NamedConf
@@ -117,7 +117,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 				in z /= oldzone || oldserial < sSerial (zSOA zone)
 
 
-cleanupPrimary :: FilePath -> Domain -> Property
+cleanupPrimary :: FilePath -> Domain -> Property NoInfo
 cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
 	property ("removed dns primary for " ++ domain)
 		(makeChange $ removeZoneFile zonefile)
@@ -150,13 +150,14 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
 -- want to later disable DNSSEC you will need to adjust the serial number
 -- passed to mkSOA to ensure it is larger.
 signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
-signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup
+signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
   where
-	setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
+	setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") 
-		[ setupPrimary zonefile signedZoneFile hosts domain soa rs'
+		(props
-		, toProp (zoneSigned domain zonefile)
+			& setupPrimary zonefile signedZoneFile hosts domain soa rs'
-		, forceZoneSigned domain zonefile `period` recurrance
+			& zoneSigned domain zonefile
-		]
+			& forceZoneSigned domain zonefile `period` recurrance
+		)
 		`onChange` Service.reloaded "bind9"
 	
 	cleanup = cleanupPrimary zonefile domain
@@ -186,7 +187,7 @@ secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts d
 -- | This variant is useful if the primary server does not have its DNS
 -- configured via propellor.
 secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
-secondaryFor masters hosts domain = RevertableProperty setup cleanup
+secondaryFor masters hosts domain = setup <!> cleanup
   where
 	setup = pureInfoProperty desc (addNamedConf conf)
 		`requires` servingZones
@@ -214,12 +215,12 @@ otherServers wantedtype hosts domain =
 -- | Rewrites the whole named.conf.local file to serve the zones
 -- configured by `primary` and `secondary`, and ensures that bind9 is
 -- running.
-servingZones :: Property
+servingZones :: Property NoInfo
 servingZones = namedConfWritten
 	`onChange` Service.reloaded "bind9"
 	`requires` Apt.serviceInstalledRunning "bind9"
 
-namedConfWritten :: Property
+namedConfWritten :: Property NoInfo
 namedConfWritten = property "named.conf configured" $ do
 	zs <- getNamedConf
 	ensureProperty $

src/Propellor/Property/DnsSec.hs

@@ -8,7 +8,7 @@ import qualified Propellor.Property.File as File
 -- signedPrimary uses this, so this property does not normally need to be
 -- used directly.
 keysInstalled :: Domain -> RevertableProperty
-keysInstalled domain = RevertableProperty setup cleanup
+keysInstalled domain = setup <!> cleanup
   where
 	setup = propertyList "DNSSEC keys installed" $
 		map installkey keys
@@ -38,16 +38,14 @@ keysInstalled domain = RevertableProperty setup cleanup
 -- signedPrimary uses this, so this property does not normally need to be
 -- used directly.
 zoneSigned :: Domain -> FilePath -> RevertableProperty
-zoneSigned domain zonefile = RevertableProperty setup cleanup
+zoneSigned domain zonefile = setup <!> cleanup
   where
 	setup = check needupdate (forceZoneSigned domain zonefile)
 		`requires` toProp (keysInstalled domain)
 	
-	cleanup = combineProperties ("removed signed zone for " ++ domain)
+	cleanup = File.notPresent (signedZoneFile zonefile)
-		[ File.notPresent (signedZoneFile zonefile)
+		`before` File.notPresent dssetfile
-		, File.notPresent dssetfile
+		`before` toProp (revert (keysInstalled domain))
-		, toProp (revert (keysInstalled domain))
-		]
 	
 	dssetfile = dir </> "-" ++ domain ++ "."
 	dir = takeDirectory zonefile
@@ -65,7 +63,7 @@ zoneSigned domain zonefile = RevertableProperty setup cleanup
 		t2 <- getModificationTime f
 		return (t2 >= t1)
 
-forceZoneSigned :: Domain -> FilePath -> Property
+forceZoneSigned :: Domain -> FilePath -> Property NoInfo
 forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
 	salt <- take 16 <$> saltSha1
  	let p = proc "dnssec-signzone"

src/Propellor/Property/Docker.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 -- | Docker support for propellor
 --
@@ -40,6 +40,7 @@ module Propellor.Property.Docker (
 
 import Propellor hiding (init)
 import Propellor.Types.Docker
+import Propellor.Types.CmdLine
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Shim as Shim
@@ -55,12 +56,12 @@ import Data.List hiding (init)
 import Data.List.Utils
 import qualified Data.Map as M
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["docker.io"]
 
 -- | Configures docker with an authentication file, so that images can be
 -- pushed to index.docker.io. Optional.
-configured :: Property
+configured :: Property HasInfo
 configured = prop `requires` installed
   where
 	prop = withPrivData src anyContext $ \getcfg ->
@@ -77,10 +78,10 @@ type ContainerName = String
 -- | A docker container.
 data Container = Container Image Host
 
-instance Hostlike Container where
+instance PropAccum Container where
 	(Container i h) & p = Container i (h & p)
 	(Container i h) &^ p = Container i (h &^ p)
-	getHost (Container _ h) = h
+	getProperties (Container _ h) = hostProperties h
 
 -- | Defines a Container with a given name, image, and properties.
 -- Properties can be added to configure the Container.
@@ -105,8 +106,9 @@ container cn image = Container image (Host cn [] info)
 -- Reverting this property ensures that the container is stopped and
 -- removed.
 docked :: Container -> RevertableProperty
-docked ctr@(Container _ h) = RevertableProperty
+docked ctr@(Container _ h) =
 	(propigateContainerInfo ctr (go "docked" setup))
+		<!>
 	(go "undocked" teardown)
   where
 	cn = hostName h
@@ -133,10 +135,14 @@ docked ctr@(Container _ h) = RevertableProperty
 					]
 			]
 
-propigateContainerInfo :: Container -> Property -> Property
+propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
-propigateContainerInfo ctr@(Container _ h) p =
+propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p'
-	propigateInfo ctr p (<> dockerinfo)
   where
+	p' = infoProperty
+		(propertyDesc p)
+		(propertySatisfy p)
+		(propertyInfo p <> dockerinfo)
+		(propertyChildren p)
 	dockerinfo = dockerInfo $
 		mempty { _dockerContainers = M.singleton (hostName h) h }
 
@@ -164,7 +170,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
 -- that were not set up using propellor.
 --
 -- Generally, should come after the properties for the desired containers.
-garbageCollected :: Property
+garbageCollected :: Property NoInfo
 garbageCollected = propertyList "docker garbage collected"
 	[ gccontainers
 	, gcimages
@@ -180,7 +186,7 @@ garbageCollected = propertyList "docker garbage collected"
 -- Currently, this consists of making pam_loginuid lines optional in
 -- the pam config, to work around <https://github.com/docker/docker/issues/5663>
 -- which affects docker 1.2.0.
-tweaked :: Property
+tweaked :: Property NoInfo
 tweaked = trivial $
 	cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"]
 	`describe` "tweaked for docker"
@@ -191,7 +197,7 @@ tweaked = trivial $
 -- other GRUB_CMDLINE_LINUX_DEFAULT settings.
 --
 -- Only takes effect after reboot. (Not automated.)
-memoryLimited :: Property
+memoryLimited :: Property NoInfo
 memoryLimited = "/etc/default/grub" `File.containsLine` cfg
 	`describe` "docker memory limited" 
 	`onChange` cmdProperty "update-grub" []
@@ -208,44 +214,44 @@ type RunParam = String
 type Image = String
 
 -- | Set custom dns server for container.
-dns :: String -> Property
+dns :: String -> Property HasInfo
 dns = runProp "dns"
 
 -- | Set container host name.
-hostname :: String -> Property
+hostname :: String -> Property HasInfo
 hostname = runProp "hostname"
 
 -- | Set name of container.
-name :: String -> Property
+name :: String -> Property HasInfo
 name = runProp "name"
 
 -- | Publish a container's port to the host
 -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> Property
+publish :: String -> Property HasInfo
 publish = runProp "publish"
 
 -- | Expose a container's port without publishing it.
-expose :: String -> Property
+expose :: String -> Property HasInfo
 expose = runProp "expose"
 
 -- | Username or UID for container.
-user :: String -> Property
+user :: String -> Property HasInfo
 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 -> Property
+volume :: String -> Property HasInfo
 volume = runProp "volume"
 
 -- | Mount a volume from the specified container into the current
 -- container.
-volumes_from :: ContainerName -> Property
+volumes_from :: ContainerName -> Property HasInfo
 volumes_from cn = genProp "volumes-from" $ \hn ->
 	fromContainerId (ContainerId hn cn)
 
 -- | Work dir inside the container. 
-workdir :: String -> Property
+workdir :: String -> Property HasInfo
 workdir = runProp "workdir"
 
 -- | Memory limit for container.
@@ -253,18 +259,18 @@ workdir = runProp "workdir"
 --
 -- Note: Only takes effect when the host has the memoryLimited property
 -- enabled.
-memory :: String -> Property
+memory :: String -> Property HasInfo
 memory = runProp "memory"
 
 -- | CPU shares (relative weight).
 --
 -- By default, all containers run at the same priority, but you can tell
 -- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property
+cpuShares :: Int -> Property HasInfo
 cpuShares = runProp "cpu-shares" . show
 
 -- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property
+link :: ContainerName -> ContainerAlias -> Property HasInfo
 link linkwith calias = genProp "link" $ \hn ->
 	fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
 
@@ -276,19 +282,19 @@ type ContainerAlias = String
 -- propellor; as well as keeping badly behaved containers running,
 -- it ensures that containers get started back up after reboot or
 -- after docker is upgraded.
-restartAlways :: Property
+restartAlways :: Property HasInfo
 restartAlways = runProp "restart" "always"
 
 -- | Docker will restart the container if it exits nonzero.
 -- If a number is provided, it will be restarted only up to that many
 -- times.
-restartOnFailure :: Maybe Int -> Property
+restartOnFailure :: Maybe Int -> Property HasInfo
 restartOnFailure Nothing = runProp "restart" "on-failure"
 restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
 
 -- | Makes docker not restart a container when it exits
 -- Note that this includes not restarting it on boot!
-restartNever :: Property
+restartNever :: Property HasInfo
 restartNever = runProp "restart" "no"
 
 -- | A container is identified by its name, and the host
@@ -322,12 +328,12 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
 myContainerSuffix :: String
 myContainerSuffix = ".propellor"
 
-containerDesc :: ContainerId -> Property -> Property
+containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
 containerDesc cid p = p `describe` desc
   where
 	desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
 
-runningContainer :: ContainerId -> Image -> [RunParam] -> Property
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo
 runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
 	l <- liftIO $ listContainers RunningContainers
 	if cid `elem` l
@@ -442,7 +448,7 @@ init s = case toContainerId s of
 
 -- | Once a container is running, propellor can be run inside
 -- it to provision it.
-provisionContainer :: ContainerId -> Property
+provisionContainer :: ContainerId -> Property NoInfo
 provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
 	let params = ["--continue", show $ toChain cid]
@@ -472,7 +478,8 @@ chain hostlist hn s = case toContainerId s of
 		changeWorkingDirectory localdir
 		onlyProcess (provisioningLock cid) $ do
 			r <- runPropellor h $ ensureProperties $
-				hostProperties h
+				map ignoreInfo $
+					hostProperties h
 			putStrLn $ "\n" ++ show r
 
 stopContainer :: ContainerId -> IO Bool
@@ -481,7 +488,7 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
 startContainer :: ContainerId -> IO Bool
 startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
 
-stoppedContainer :: ContainerId -> Property
+stoppedContainer :: ContainerId -> Property NoInfo
 stoppedContainer cid = containerDesc cid $ property desc $ 
 	ifM (liftIO $ elem cid <$> listContainers RunningContainers)
 		( liftIO cleanup `after` ensureProperty 
@@ -533,13 +540,13 @@ listContainers status =
 listImages :: IO [Image]
 listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
-runProp :: String -> RunParam -> Property
+runProp :: String -> RunParam -> Property HasInfo
 runProp field val = pureInfoProperty (param) $ dockerInfo $
 	mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
   where
 	param = field++"="++val
 
-genProp :: String -> (HostName -> RunParam) -> Property
+genProp :: String -> (HostName -> RunParam) -> Property HasInfo
 genProp field mkval = pureInfoProperty field $ dockerInfo $
 	mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
 

src/Propellor/Property/File.hs

@@ -9,7 +9,7 @@ import System.PosixCompat.Types
 type Line = String
 
 -- | Replaces all the content of a file.
-hasContent :: FilePath -> [Line] -> Property
+hasContent :: FilePath -> [Line] -> Property NoInfo
 f `hasContent` newcontent = fileProperty ("replace " ++ f)
 	(\_oldcontent -> newcontent) f
 
@@ -17,25 +17,25 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f)
 --
 -- The file's permissions are preserved if the file already existed.
 -- Otherwise, they're set to 600.
-hasPrivContent :: IsContext c => FilePath -> c -> Property
+hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo
 hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
 
 -- | Like hasPrivContent, but allows specifying a source
 -- for PrivData, rather than using PrivDataSourceFile.
-hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property
+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
 hasPrivContentFrom = hasPrivContent' writeFileProtected
 
 -- | Leaves the file at its default or current mode,
 -- allowing "private" data to be read.
 --
 -- Use with caution!
-hasPrivContentExposed :: IsContext c => FilePath -> c -> Property
+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
 hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
 
-hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property
+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
 hasPrivContentExposedFrom = hasPrivContent' writeFile
 
-hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property HasInfo
 hasPrivContent' writer source f context = 
 	withPrivData source context $ \getcontent -> 
 		property desc $ getcontent $ \privcontent -> 
@@ -45,10 +45,10 @@ hasPrivContent' writer source f context =
 	desc = "privcontent " ++ f
 
 -- | Ensures that a line is present in a file, adding it to the end if not.
-containsLine :: FilePath -> Line -> Property
+containsLine :: FilePath -> Line -> Property NoInfo
 f `containsLine` l = f `containsLines` [l]
 
-containsLines :: FilePath -> [Line] -> Property
+containsLines :: FilePath -> [Line] -> Property NoInfo
 f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
   where
 	go content = content ++ filter (`notElem` content) ls
@@ -56,17 +56,17 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
 -- | Ensures that a line is not present in a file.
 -- Note that the file is ensured to exist, so if it doesn't, an empty
 -- file will be written.
-lacksLine :: FilePath -> Line -> Property
+lacksLine :: FilePath -> Line -> Property NoInfo
 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 :: FilePath -> Property NoInfo
 notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ 
 	makeChange $ nukeFile f
 
-fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
+fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
 fileProperty = fileProperty' writeFile
-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property
+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
 fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
   where
 	go True = do
@@ -86,12 +86,12 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
 		setOwnerAndGroup f' (fileOwner s) (fileGroup s)
 
 -- | Ensures a directory exists.
-dirExists :: FilePath -> Property
+dirExists :: FilePath -> Property NoInfo
 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 :: FilePath -> UserName -> GroupName -> Property NoInfo
 ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
 	r <- ensureProperty $ cmdProperty "chown" [og, f]
 	if r == FailedChange
@@ -101,7 +101,7 @@ ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
 	og = owner ++ ":" ++ group
 
 -- | Ensures that a file/dir has the specfied mode.
-mode :: FilePath -> FileMode -> Property
+mode :: FilePath -> FileMode -> Property NoInfo
 mode f v = property (f ++ " mode " ++ show v) $ do
 	liftIO $ modifyFileMode f (\_old -> v)
 	noChange

src/Propellor/Property/Firewall.hs

@@ -9,6 +9,7 @@ module Propellor.Property.Firewall (
 	Target(..),
 	Proto(..),
 	Rules(..),
+	Port,
 	ConnectionState(..)
 ) where
 
@@ -21,10 +22,10 @@ import Utility.SafeCommand
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Network as Network
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["iptables"]
 
-rule :: Chain -> Target -> Rules -> Property
+rule :: Chain -> Target -> Rules -> Property NoInfo
 rule c t rs = property ("firewall rule: " <> show r) addIpTable
   where
 	r = Rule c t rs

src/Propellor/Property/Git.hs

@@ -13,7 +13,7 @@ import Data.List
 --
 -- Note that reverting this property does not remove or stop inetd.
 daemonRunning :: FilePath -> RevertableProperty
-daemonRunning exportdir = RevertableProperty setup unsetup
+daemonRunning exportdir = setup <!> unsetup
   where
 	setup = containsLine conf (mkl "tcp4")
 		`requires`
@@ -48,7 +48,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup
 		, exportdir
 		]
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["git"]
 
 type RepoUrl = String
@@ -62,7 +62,7 @@ type Branch = String
 -- it will be recursively deleted first.
 --
 -- A branch can be specified, to check out.
-cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
+cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo
 cloned owner url dir mbranch = check originurl (property desc checkout)
 	`requires` installed
   where
@@ -98,7 +98,7 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
 
 data GitShared = Shared GroupName | SharedAll | NotShared
 
-bareRepo :: FilePath -> UserName -> GitShared -> Property
+bareRepo :: FilePath -> UserName -> GitShared -> Property NoInfo
 bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
 	dirExists repo : case gitshared of
 		NotShared ->

src/Propellor/Property/Gpg.hs

@@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
 
 import System.PosixCompat
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["gnupg"]
 
 -- A numeric id, or a description of the key, in a form understood by gpg.
@@ -20,7 +20,7 @@ newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String }
 --
 -- Recommend only using this for low-value dedicated role keys.
 -- No attempt has been made to scrub the key out of memory once it's used.
-keyImported :: GpgKeyId -> UserName -> Property
+keyImported :: GpgKeyId -> UserName -> Property HasInfo
 keyImported (GpgKeyId keyid) user = flagFile' prop genflag
 	`requires` installed
   where

src/Propellor/Property/Group.hs

@@ -4,7 +4,7 @@ import Propellor
 
 type GID = Int
 
-exists :: GroupName -> Maybe GID -> Property
+exists :: GroupName -> Maybe GID -> Property NoInfo
 exists group' mgid = check test (cmdProperty "addgroup" $ args mgid)
 	`describe` unwords ["group", group']
   where

src/Propellor/Property/Grub.hs

@@ -4,10 +4,10 @@ import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 
--- | Eg, "hd0,0" or "xen/xvda1"
+-- | Eg, \"hd0,0\" or \"xen/xvda1\"
 type GrubDevice = String
 
--- | Eg, "/dev/sda"
+-- | Eg, \"\/dev/sda\"
 type OSDevice = String
 
 type TimeoutSecs = Int
@@ -21,7 +21,7 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
 -- This includes running update-grub, so that the grub boot menu is
 -- created. It will be automatically updated when kernel packages are
 -- installed.
-installed :: BIOS -> Property
+installed :: BIOS -> Property NoInfo
 installed bios = 
 	Apt.installed [pkg] `describe` "grub package installed"
 		`before`
@@ -43,7 +43,7 @@ installed bios =
 -- on the device; it always does the work to reinstall it. It's a good idea
 -- to arrange for this property to only run once, by eg making it be run
 -- onChange after OS.cleanInstallOnce.
-boots :: OSDevice -> Property
+boots :: OSDevice -> Property NoInfo
 boots dev = cmdProperty "grub-install" [dev]
 	`describe` ("grub boots " ++ dev)
 
@@ -55,7 +55,7 @@ boots dev = cmdProperty "grub-install" [dev]
 --
 -- The rootdev should be in the form "hd0", while the bootdev is in the form
 -- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
 chainPVGrub rootdev bootdev timeout = combineProperties desc
 	[ File.dirExists "/boot/grub"
 	, "/boot/grub/menu.lst" `File.hasContent`

src/Propellor/Property/HostingProvider/CloudAtCost.hs

@@ -6,7 +6,7 @@ import qualified Propellor.Property.File as File
 import qualified Propellor.Property.User as User
 
 -- Clean up a system as installed by cloudatcost.com
-decruft :: Property
+decruft :: Property NoInfo
 decruft = propertyList "cloudatcost cleanup"
 	[ Hostname.sane
 	, "worked around grub/lvm boot bug #743126" ==>

src/Propellor/Property/HostingProvider/DigitalOcean.hs

@@ -18,7 +18,7 @@ import Data.List
 -- If the power is cycled, the non-distro kernel still boots up.
 -- So, this property also checks if the running kernel is present in /boot,
 -- and if not, reboots immediately into a distro kernel.
-distroKernel :: Property
+distroKernel :: Property NoInfo
 distroKernel = propertyList "digital ocean distro kernel hack"
 	[ Apt.installed ["grub-pc", "kexec-tools", "file"]
 	, "/etc/default/kexec" `File.containsLines`

src/Propellor/Property/HostingProvider/Linode.hs

@@ -6,5 +6,5 @@ import qualified Propellor.Property.Grub as Grub
 -- | Linode's pv-grub-x86_64 does not currently support booting recent
 -- Debian kernels compressed with xz. This sets up pv-grub chaing to enable
 -- it.
-chainPVGrub :: Grub.TimeoutSecs -> Property
+chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo
 chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"

src/Propellor/Property/Hostname.hs

@@ -17,10 +17,10 @@ import Data.List
 -- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any
 -- other hostnames there is not best practices and can lead to annoying
 -- messages from eg, apache.
-sane :: Property
+sane :: Property NoInfo
 sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
 
-setTo :: HostName -> Property
+setTo :: HostName -> Property NoInfo
 setTo hn = combineProperties desc go
   where
 	desc = "hostname " ++ hn
@@ -46,7 +46,7 @@ setTo hn = combineProperties desc go
 
 -- | Makes </etc/resolv.conf> contain search and domain lines for 
 -- the domain that the hostname is in.
-searchDomain :: Property
+searchDomain :: Property NoInfo
 searchDomain = property desc (ensureProperty . go =<< asks hostName)
   where
 	desc = "resolv.conf search and domain configured"

src/Propellor/Property/Journald.hs

@@ -0,0 +1,53 @@
+module Propellor.Property.Journald where
+import Propellor
+import qualified Propellor.Property.Systemd as Systemd
+import Utility.DataUnits
+
+-- | Configures journald, restarting it so the changes take effect.
+configured :: Systemd.Option -> String -> Property NoInfo
+configured option value =
+	Systemd.configured "/etc/systemd/journald.conf" option value
+		`onChange` Systemd.restarted "systemd-journald"
+
+-- The string is parsed to get a data size.
+-- Examples: "100 megabytes" or "0.5tb"
+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
+
+systemMaxUse :: DataSize -> Property NoInfo
+systemMaxUse = configuredSize "SystemMaxUse"
+
+runtimeMaxUse :: DataSize -> Property NoInfo
+runtimeMaxUse = configuredSize "RuntimeMaxUse"
+
+systemKeepFree :: DataSize -> Property NoInfo
+systemKeepFree = configuredSize "SystemKeepFree"
+
+runtimeKeepFree :: DataSize -> Property NoInfo
+runtimeKeepFree = configuredSize "RuntimeKeepFree"
+
+systemMaxFileSize :: DataSize -> Property NoInfo
+systemMaxFileSize = configuredSize "SystemMaxFileSize"
+
+runtimeMaxFileSize :: DataSize -> Property NoInfo
+runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"
+
+-- Generates size units as used in journald.conf.
+systemdSizeUnits :: Integer -> String
+systemdSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz)
+  where
+	cfgfileunits :: [Unit]
+	cfgfileunits =
+	        [ Unit (p 6) "E" "exabyte"
+		, Unit (p 5) "P" "petabyte"
+		, Unit (p 4) "T" "terabyte"
+		, Unit (p 3) "G" "gigabyte"
+		, Unit (p 2) "M" "megabyte"
+		, Unit (p 1) "K" "kilobyte"
+		]
+        p :: Integer -> Integer
+        p n = 1024^n

src/Propellor/Property/List.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Property.List (
+	PropertyList(..),
+	PropertyListType,
+) where
+
+import Propellor.Types
+import Propellor.Engine
+import Propellor.PropAccum
+
+import Data.Monoid
+
+class PropertyList l where
+	-- | Combines a list of properties, resulting in a single property
+	-- that when run will run each property in the list in turn,
+	-- and print out the description of each as it's run. Does not stop
+	-- on failure; does propigate overall success/failure.
+	--
+	-- Note that Property HasInfo and Property NoInfo are not the same
+	-- type, and so cannot be mixed in a list. To make a list of
+	-- mixed types, which can also include RevertableProperty,
+	-- use `props`:
+	--
+	-- > propertyList "foo" $ props
+	-- >	& someproperty
+	-- >	! oldproperty
+	-- > 	& otherproperty
+	propertyList :: Desc -> l -> Property (PropertyListType l)
+
+	-- | Combines a list of properties, resulting in one property that
+	-- ensures each in turn. Stops if a property fails.
+	combineProperties :: Desc -> l -> Property (PropertyListType l)
+
+-- | Type level function to calculate whether a PropertyList has Info.
+type family PropertyListType t
+type instance PropertyListType [Property HasInfo] = HasInfo
+type instance PropertyListType [Property NoInfo] = NoInfo
+type instance PropertyListType PropList = HasInfo
+
+instance PropertyList [Property NoInfo] where
+	propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
+	combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
+
+instance PropertyList [Property HasInfo] where
+	-- It's ok to use ignoreInfo here, because the ps are made the
+	-- child properties of the property, and so their info is visible
+	-- that way.
+	propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
+	combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
+
+instance PropertyList PropList where
+	propertyList desc = propertyList desc . getProperties
+	combineProperties desc = combineProperties desc . getProperties
+
+combineSatisfy :: [Property i] -> Result -> Propellor Result
+combineSatisfy [] rs = return rs
+combineSatisfy (l:ls) rs = do
+	r <- ensureProperty $ ignoreInfo l
+	case r of
+		FailedChange -> return FailedChange
+		_ -> combineSatisfy ls (r <> rs)

src/Propellor/Property/Network.hs

@@ -3,28 +3,93 @@ module Propellor.Property.Network where
 import Propellor
 import Propellor.Property.File
 
-interfaces :: FilePath
-interfaces = "/etc/network/interfaces"
-
--- | 6to4 ipv6 connection, should work anywhere
-ipv6to4 :: Property
-ipv6to4 = fileProperty "ipv6to4" go interfaces
-	`onChange` ifUp "sit0"
-  where
-	go ls
-		| all (`elem` ls) stanza = ls
-		| otherwise = ls ++ stanza
-	stanza =
-		[ "# Automatically added by propeller"
-		, "iface sit0 inet6 static"
-		, "\taddress 2002:5044:5531::1"
-		, "\tnetmask 64"
-		, "\tgateway ::192.88.99.1"
-		, "auto sit0"
-		, "# End automatically added by propeller"
-		]
-
 type Interface = String
 
-ifUp :: Interface -> Property
+ifUp :: Interface -> Property NoInfo
 ifUp iface = cmdProperty "ifup" [iface]
+
+-- | Resets /etc/network/interfaces to a clean and empty state,
+-- containing just the standard loopback interface, and with
+-- interfacesD enabled.
+--
+-- This can be used as a starting point to defining other interfaces.
+--
+-- No interfaces are brought up or down by this property.
+cleanInterfacesFile :: Property NoInfo
+cleanInterfacesFile = hasContent interfacesFile
+	[ "# Deployed by propellor, do not edit."
+	, ""
+	, "source-directory interfaces.d"
+	, ""
+	, "# The loopback network interface"
+	, "auto lo"
+	, "iface lo inet loopback"
+	]
+	`describe` ("clean " ++ interfacesFile)
+
+-- | Writes a static interface file for the specified interface.
+--
+-- The interface has to be up already. It could have been brought up by
+-- DHCP, or by other means. The current ipv4 addresses
+-- and routing configuration of the interface are written into the file.
+--
+-- If the interface file already exists, this property does nothing,
+-- no matter its content.
+-- 
+-- (ipv6 addresses are not included because it's assumed they come up
+-- automatically in most situations.)
+static :: Interface -> Property NoInfo
+static iface = check (not <$> doesFileExist f) setup
+	`describe` desc
+	`requires` interfacesDEnabled
+  where
+	f = interfaceDFile iface
+	desc = "static " ++ iface
+	setup = property desc $ do
+		ls <- liftIO $ lines <$> readProcess "ip"
+			["-o", "addr", "show", iface, "scope", "global"]
+		stanzas <- liftIO $ concat <$> mapM mkstanza ls
+		ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas
+	mkstanza ipline = case words ipline of
+		-- Note that the IP address is written CIDR style, so
+		-- the netmask does not need to be specified separately.
+		(_:iface':"inet":addr:_) | iface' == iface -> do
+			gw <- getgateway
+			return $ catMaybes
+				[ Just $ "iface " ++ iface ++ " inet static"
+				, Just $ "\taddress " ++ addr
+				, ("\tgateway " ++) <$> gw
+				]
+		_ -> return []
+	getgateway = do
+		rs <- lines <$> readProcess "ip"
+			["route", "show", "scope", "global", "dev", iface]
+		return $ case words <$> headMaybe rs of
+			Just ("default":"via":gw:_) -> Just gw
+			_ -> Nothing
+
+-- | 6to4 ipv6 connection, should work anywhere
+ipv6to4 :: Property NoInfo
+ipv6to4 = hasContent (interfaceDFile "sit0")
+	[ "# Deployed by propellor, do not edit."
+	, "iface sit0 inet6 static"
+	, "\taddress 2002:5044:5531::1"
+	, "\tnetmask 64"
+	, "\tgateway ::192.88.99.1"
+	, "auto sit0"
+	]
+	`describe` "ipv6to4"
+	`requires` interfacesDEnabled
+	`onChange` ifUp "sit0"
+
+interfacesFile :: FilePath
+interfacesFile = "/etc/network/interfaces"
+
+-- | A file in the interfaces.d directory.
+interfaceDFile :: Interface -> FilePath
+interfaceDFile iface = "/etc/network/interfaces.d" </> iface
+
+-- | Ensures that files in the the interfaces.d directory are used.
+interfacesDEnabled :: Property NoInfo
+interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
+	`describe` "interfaces.d directory enabled"

src/Propellor/Property/Nginx.hs

@@ -9,7 +9,7 @@ import System.Posix.Files
 type ConfigFile = [String]
 
 siteEnabled :: HostName -> ConfigFile -> RevertableProperty
-siteEnabled hn cf = RevertableProperty enable disable
+siteEnabled hn cf = enable <!> disable
   where
 	enable = check test prop
 		`describe` ("nginx site enabled " ++ hn)
@@ -27,7 +27,7 @@ siteEnabled hn cf = RevertableProperty enable disable
 		`requires` installed
 		`onChange` reloaded
 
-siteAvailable :: HostName -> ConfigFile -> Property
+siteAvailable :: HostName -> ConfigFile -> Property NoInfo
 siteAvailable hn cf = ("nginx site available " ++ hn) ==>
 	siteCfg hn `File.hasContent` (comment : cf)
   where
@@ -42,11 +42,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn
 siteValRelativeCfg :: HostName -> FilePath
 siteValRelativeCfg hn = "../sites-available/" ++ hn
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["nginx"]
 
-restarted :: Property
+restarted :: Property NoInfo
 restarted = Service.restarted "nginx"
 
-reloaded :: Property
+reloaded :: Property NoInfo
 reloaded = Service.reloaded "nginx"

src/Propellor/Property/OS.hs

@@ -10,6 +10,7 @@ module Propellor.Property.OS (
 import Propellor
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Ssh as Ssh
+import qualified Propellor.Property.Network as Network
 import qualified Propellor.Property.User as User
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Reboot as Reboot
@@ -51,7 +52,7 @@ import Control.Exception (throw)
 -- >    `onChange` propertyList "fixing up after clean install"
 -- >        [ preserveNetwork
 -- >        , preserveResolvConf
--- >        , preserverRootSshAuthorized
+-- >        , preserveRootSshAuthorized
 -- >        , Apt.update
 -- >        -- , Grub.boots "/dev/sda"
 -- >        --   `requires` Grub.installed Grub.PC
@@ -64,7 +65,7 @@ import Control.Exception (throw)
 -- > & User.accountFor "joey"
 -- > & User.hasSomePassword "joey"
 -- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property
+cleanInstallOnce :: Confirmation -> Property NoInfo
 cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 	go `requires` confirmed "clean install confirmed" confirmation
   where
@@ -88,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 		(Just u@(System (Ubuntu _) _)) -> debootstrap u
 		_ -> error "os is not declared to be Debian or Ubuntu"
 	
-	debootstrap targetos = ensureProperty $ toProp $
+	debootstrap targetos = ensureProperty $
 		-- Ignore the os setting, and install debootstrap from
 		-- source, since we don't know what OS we're running in yet.
 		Debootstrap.built' Debootstrap.sourceInstall
@@ -179,7 +180,7 @@ massRename = go []
 
 data Confirmation = Confirmed HostName
 
-confirmed :: Desc -> Confirmation -> Property
+confirmed :: Desc -> Confirmation -> Property NoInfo
 confirmed desc (Confirmed c) = property desc $ do
 	hostname <- asks hostName
 	if hostname /= c
@@ -191,11 +192,21 @@ confirmed desc (Confirmed c) = property desc $ do
 -- | </etc/network/interfaces> is configured to bring up the network 
 -- interface that currently has a default route configured, using
 -- the same (static) IP address.
-preserveNetwork :: Property
+preserveNetwork :: Property NoInfo
-preserveNetwork = undefined -- TODO
+preserveNetwork = go `requires` Network.cleanInterfacesFile
+  where
+	go = property "preserve network configuration" $ do
+		ls <- liftIO $ lines <$> readProcess "ip"
+			["route", "list", "scope", "global"]
+		case words <$> headMaybe ls of
+			Just ("default":"via":_:"dev":iface:_) ->
+				ensureProperty $ Network.static iface
+			_ -> do
+				warningMessage "did not find any default ipv4 route"
+				return FailedChange 
 
 -- | </etc/resolv.conf> is copied from the old OS
-preserveResolvConf :: Property
+preserveResolvConf :: Property NoInfo
 preserveResolvConf = check (fileExist oldloc) $
 	property (newloc ++ " copied from old OS") $ do
 		ls <- liftIO $ lines <$> readFile oldloc
@@ -207,7 +218,7 @@ preserveResolvConf = check (fileExist oldloc) $
 -- | </root/.ssh/authorized_keys> has added to it any ssh keys that
 -- were authorized in the old OS. Any other contents of the file are
 -- retained.
-preserveRootSshAuthorized :: Property
+preserveRootSshAuthorized :: Property NoInfo
 preserveRootSshAuthorized = check (fileExist oldloc) $
 	property (newloc ++ " copied from old OS") $ do
 		ks <- liftIO $ lines <$> readFile oldloc
@@ -217,7 +228,7 @@ preserveRootSshAuthorized = check (fileExist oldloc) $
 	oldloc = oldOSDir ++ newloc
 
 -- Removes the old OS's backup from </old-os>
-oldOSRemoved :: Confirmation -> Property
+oldOSRemoved :: Confirmation -> Property NoInfo
 oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
 	go `requires` confirmed "old OS backup removal confirmed" confirmation
   where

src/Propellor/Property/Obnam.hs

@@ -36,7 +36,7 @@ data NumClients = OnlyClient | MultipleClients
 -- >		`requires` Ssh.keyImported SshRsa "root" (Context hostname)
 --
 -- How awesome is that?
-backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
 backup dir crontimes params numclients =
 	backup' dir crontimes params numclients
 		`requires` restored dir params
@@ -46,7 +46,7 @@ backup dir crontimes params numclients =
 --
 -- The gpg secret key will be automatically imported
 -- into root's keyring using Propellor.Property.Gpg.keyImported
-backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property
+backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo
 backupEncrypted dir crontimes params numclients keyid =
 	backup dir crontimes params' numclients
 		`requires` Gpg.keyImported keyid "root"
@@ -54,7 +54,7 @@ backupEncrypted dir crontimes params numclients keyid =
 	params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params
 
 -- | Does a backup, but does not automatically restore.
-backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
 backup' dir crontimes params numclients = cronjob `describe` desc
   where
 	desc = dir ++ " backed up by obnam"
@@ -80,7 +80,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 :: FilePath -> [ObnamParam] -> Property NoInfo
 restored dir params = property (dir ++ " restored by obnam") go
 	`requires` installed
   where
@@ -108,17 +108,17 @@ restored dir params = property (dir ++ " restored by obnam") go
 			, return FailedChange
 			)
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["obnam"]
 
 -- | Ensures that a recent version of obnam gets installed.
 --
 -- Only does anything for Debian Stable.
-latestVersion :: Property
+latestVersion :: Property NoInfo
 latestVersion = withOS "obnam latest version" $ \o -> case o of
 	(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $
 		Apt.setSourcesListD (stablesources suite) "obnam"
-			`requires` toProp (Apt.trustsKey key)
+			`requires` Apt.trustsKey' key
 	_ -> noChange
   where
 	stablesources suite = 

src/Propellor/Property/OpenId.hs

@@ -7,8 +7,8 @@ import qualified Propellor.Property.Service as Service
 
 import Data.List
 
-providerFor :: [UserName] -> String -> Property
+providerFor :: [UserName] -> String -> Property HasInfo
-providerFor users baseurl = propertyList desc $
+providerFor users baseurl = propertyList desc $ map toProp
 	[ Apt.serviceInstalledRunning "apache2"
 	, Apt.installed ["simpleid"]
 		`onChange` Service.restarted "apache2"

src/Propellor/Property/Postfix.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Propellor.Property.Postfix where
 
 import Propellor
@@ -9,13 +11,13 @@ import qualified Data.Map as M
 import Data.List
 import Data.Char
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.serviceInstalledRunning "postfix"
 
-restarted :: Property
+restarted :: Property NoInfo
 restarted = Service.restarted "postfix"
 
-reloaded :: Property
+reloaded :: Property NoInfo
 reloaded = Service.reloaded "postfix"
 
 -- | Configures postfix as a satellite system, which 
@@ -24,7 +26,7 @@ reloaded = Service.reloaded "postfix"
 -- The smarthost may refuse to relay mail on to other domains, without
 -- futher coniguration/keys. But this should be enough to get cron job
 -- mail flowing to a place where it will be seen.
-satellite :: Property
+satellite :: Property NoInfo
 satellite = check (not <$> mainCfIsSet "relayhost") setup
 	`requires` installed
   where
@@ -45,13 +47,17 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
 -- | Sets up a file by running a property (which the filename is passed
 -- to). If the setup property makes a change, postmap will be run on the
 -- file, and postfix will be reloaded.
-mappedFile :: FilePath -> (FilePath -> Property) -> Property
+mappedFile
+	:: Combines (Property x) (Property NoInfo)
+	=> FilePath
+	-> (FilePath -> Property x)
+	-> Property (CInfo x NoInfo)
 mappedFile f setup = setup f
 	`onChange` cmdProperty "postmap" [f]
 
 -- | Run newaliases command, which should be done after changing
 -- </etc/aliases>.
-newaliases :: Property
+newaliases :: Property NoInfo
 newaliases = trivial $ cmdProperty "newaliases" []
 
 -- | The main config file for postfix.
@@ -59,7 +65,7 @@ mainCfFile :: FilePath
 mainCfFile = "/etc/postfix/main.cf"
 
 -- | Sets a main.cf name=value pair. Does not reload postfix immediately.
-mainCf :: (String, String) -> Property
+mainCf :: (String, String) -> Property NoInfo
 mainCf (name, value) = check notset set
 		`describe` ("postfix main.cf " ++ setting)
   where
@@ -77,8 +83,8 @@ getMainCf name = parse . lines <$> readProcess "postconf" [name]
 			(_, v) -> v
 	parse [] = Nothing
 
--- | Checks if a main.cf field is set. A field that is set to "" 
+-- | Checks if a main.cf field is set. A field that is set to
--- is considered not set.
+-- the empty string is considered not set.
 mainCfIsSet :: String -> IO Bool
 mainCfIsSet name = do
 	v <- getMainCf name
@@ -96,7 +102,7 @@ mainCfIsSet name = do
 --
 -- Note that multiline configurations that continue onto the next line
 -- are not currently supported.
-dedupMainCf :: Property
+dedupMainCf :: Property NoInfo
 dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile
 
 dedupCf :: [String] -> [String]

src/Propellor/Property/Prosody.hs

@@ -11,7 +11,7 @@ type ConfigFile = [String]
 type Conf = String
 
 confEnabled :: Conf -> ConfigFile -> RevertableProperty
-confEnabled conf cf = RevertableProperty enable disable
+confEnabled conf cf = enable <!> disable
   where
 	enable = check test prop
 		`describe` ("prosody conf enabled " ++ conf)
@@ -30,7 +30,7 @@ confEnabled conf cf = RevertableProperty enable disable
 		`requires` installed
 		`onChange` reloaded
 
-confAvailable :: Conf -> ConfigFile -> Property
+confAvailable :: Conf -> ConfigFile -> Property NoInfo
 confAvailable conf cf = ("prosody conf available " ++ conf) ==>
 	confAvailPath conf `File.hasContent` (comment : cf)
   where
@@ -42,11 +42,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" </> conf <.> "cfg.lua"
 confValPath :: Conf -> FilePath
 confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua"
 
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["prosody"]
 
-restarted :: Property
+restarted :: Property NoInfo
 restarted = Service.restarted "prosody"
 
-reloaded :: Property
+reloaded :: Property NoInfo
 reloaded = Service.reloaded "prosody"

src/Propellor/Property/Reboot.hs

@@ -3,7 +3,7 @@ module Propellor.Property.Reboot where
 import Propellor
 import Utility.SafeCommand
 
-now :: Property
+now :: Property NoInfo
 now = cmdProperty "reboot" []
 	`describe` "reboot now"
 
@@ -14,7 +14,7 @@ now = cmdProperty "reboot" []
 --
 -- The reboot can be forced to run, which bypasses the init system. Useful
 -- if the init system might not be running for some reason.
-atEnd :: Bool -> (Result -> Bool) -> Property
+atEnd :: Bool -> (Result -> Bool) -> Property NoInfo
 atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
 	endAction "rebooting" atend
 	return NoChange

src/Propellor/Property/Scheduled.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Propellor.Property.Scheduled
 	( period
 	, periodParse
@@ -18,8 +20,8 @@ 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 :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
-period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do
+period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
 	lasttime <- liftIO $ getLastChecked (propertyDesc prop)
 	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
 	t <- liftIO localNow
@@ -34,7 +36,7 @@ period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy ->
 	desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
 
 -- | Like period, but parse a human-friendly string.
-periodParse :: Property -> String -> Property
+periodParse :: Property NoInfo -> String -> Property NoInfo
 periodParse prop s = case toRecurrance s of
 	Just recurrance -> period prop recurrance
 	Nothing -> property "periodParse" $ do

src/Propellor/Property/Service.hs

@@ -12,16 +12,16 @@ type ServiceName = String
 -- Note that due to the general poor state of init scripts, the best
 -- we can do is try to start the service, and if it fails, assume
 -- this means it's already running.
-running :: ServiceName -> Property
+running :: ServiceName -> Property NoInfo
 running = signaled "start" "running"
 
-restarted :: ServiceName -> Property
+restarted :: ServiceName -> Property NoInfo
 restarted = signaled "restart" "restarted"
 
-reloaded :: ServiceName -> Property
+reloaded :: ServiceName -> Property NoInfo
 reloaded = signaled "reload" "reloaded"
 
-signaled :: String -> Desc -> ServiceName -> Property
+signaled :: String -> Desc -> ServiceName -> Property NoInfo
 signaled cmd desc svc = property (desc ++ " " ++ svc) $ do
 	void $ ensureProperty $
 		scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]

src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Propellor.Property.SiteSpecific.GitAnnexBuilder where
 
 import Propellor
@@ -23,54 +25,56 @@ builddir = gitbuilderdir </> "build"
 
 type TimeOut = String -- eg, 5h
 
-autobuilder :: Architecture -> CronTimes -> TimeOut -> Property
+autobuilder :: Architecture -> CronTimes -> TimeOut -> Property HasInfo
-autobuilder arch crontimes timeout = combineProperties "gitannexbuilder"
+autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
-	[ Apt.serviceInstalledRunning "cron"
+	& Apt.serviceInstalledRunning "cron"
-	, Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $
+	& Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir
-		"git pull ; timeout " ++ timeout ++ " ./autobuild"
+		("git pull ; timeout " ++ timeout ++ " ./autobuild")
+	& rsyncpassword
+  where
+	context = Context ("gitannexbuilder " ++ arch)
+	pwfile = homedir </> "rsyncpassword"
 	-- 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.
-	, withPrivData (Password builduser) context $ \getpw ->
+	rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
 		property "rsync password" $ getpw $ \pw -> do
 			oldpw <- liftIO $ catchDefaultIO "" $
 				readFileStrict pwfile
 			if pw /= oldpw
 				then makeChange $ writeFile pwfile pw
 				else noChange
-	]
-  where
-	context = Context ("gitannexbuilder " ++ arch)
-	pwfile = homedir </> "rsyncpassword"
 
-tree :: Architecture -> Property
+tree :: Architecture -> Property HasInfo
-tree buildarch = combineProperties "gitannexbuilder tree"
+tree buildarch = combineProperties "gitannexbuilder tree" $ props
-	[ Apt.installed ["git"]
+	& Apt.installed ["git"]
 	-- gitbuilderdir directory already exists when docker volume is used,
 	-- but with wrong owner.
-	, File.dirExists gitbuilderdir
+	& File.dirExists gitbuilderdir
-	, File.ownerGroup gitbuilderdir builduser builduser
+	& File.ownerGroup gitbuilderdir builduser builduser
-	, check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $ 
+	& gitannexbuildercloned
+	& builddircloned
+  where
+	gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $ 
 		userScriptProperty builduser
 			[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
 			, "cd " ++ gitbuilderdir
 			, "git checkout " ++ buildarch
 			]
 			`describe` "gitbuilder setup"
-	, check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
+	builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
 		[ "git clone git://git-annex.branchable.com/ " ++ builddir
 		]
-	]
 
-buildDepsApt :: Property
+buildDepsApt :: Property HasInfo
-buildDepsApt = combineProperties "gitannexbuilder build deps"
+buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
-	[ Apt.buildDep ["git-annex"]
+	& Apt.buildDep ["git-annex"]
-	, Apt.installed ["liblockfile-simple-perl"]
+	& Apt.installed ["liblockfile-simple-perl"]
-	, buildDepsNoHaskellLibs
+	& buildDepsNoHaskellLibs
-	, "git-annex source build deps installed" ==> Apt.buildDepIn builddir
+	& Apt.buildDepIn builddir
-	]
+		`describe` "git-annex source build deps installed"
 
-buildDepsNoHaskellLibs :: Property
+buildDepsNoHaskellLibs :: Property NoInfo
 buildDepsNoHaskellLibs = Apt.installed
 	["git", "rsync", "moreutils", "ca-certificates",
 	"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",
@@ -82,7 +86,7 @@ buildDepsNoHaskellLibs = Apt.installed
 
 -- Installs current versions of git-annex's deps from cabal, but only
 -- does so once.
-cabalDeps :: Property
+cabalDeps :: Property NoInfo
 cabalDeps = flagFile go cabalupdated
 	where
 		go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
@@ -108,7 +112,13 @@ androidAutoBuilderContainer dockerImage crontimes timeout =
 		& autobuilder "android" crontimes timeout
 
 -- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container
+androidContainer
+	:: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
+	=> (System -> Docker.Image)
+	-> Docker.ContainerName
+	-> Property i
+	-> FilePath
+	-> Docker.Container
 androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
 	(dockerImage osver)
 	& os osver

src/Propellor/Property/SiteSpecific/GitHome.hs

@@ -6,7 +6,7 @@ import Propellor.Property.User
 import Utility.SafeCommand
 
 -- | Clones Joey Hess's git home directory, and runs its fixups script.
-installedFor :: UserName -> Property
+installedFor :: UserName -> Property NoInfo
 installedFor user = check (not <$> hasGitDir user) $ 
 	property ("githome " ++ user) (go =<< liftIO (homedir user))
 		`requires` Apt.installed ["git"]

src/Propellor/Property/SiteSpecific/JoeySites.hs

@@ -22,22 +22,18 @@ import Data.List
 import System.Posix.Files
 import Data.String.Utils
 
-oldUseNetServer :: [Host] -> Property
+oldUseNetServer :: [Host] -> Property HasInfo
-oldUseNetServer hosts = propertyList ("olduse.net server")
+oldUseNetServer hosts = propertyList "olduse.net server" $ props
-	[ oldUseNetInstalled "oldusenet-server"
+	& oldUseNetInstalled "oldusenet-server"
-	, Obnam.latestVersion
+	& Obnam.latestVersion
-	, Obnam.backup datadir "33 4 * * *"
+	& oldUseNetBackup
-		[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
+	& check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
-		, "--client-name=spool"
+		(property "olduse.net spool in place" $ makeChange $ do
-		] Obnam.OnlyClient
-		`requires` Ssh.keyImported SshRsa "root" (Context "olduse.net")
-		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
-	, check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $
-		property "olduse.net spool in place" $ makeChange $ do
 			removeDirectoryRecursive newsspool
 			createSymbolicLink (datadir </> "news") newsspool
-	, Apt.installed ["leafnode"]
+		)
-	, "/etc/news/leafnode/config" `File.hasContent` 
+	& Apt.installed ["leafnode"]
+	& "/etc/news/leafnode/config" `File.hasContent` 
 		[ "# olduse.net configuration (deployed by propellor)"
 		, "expire = 1000000" -- no expiry via texpire
 		, "server = " -- no upstream server
@@ -45,17 +41,22 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
 		, "allowSTRANGERS = 42" -- lets anyone connect
 		, "nopost = 1" -- no new posting (just gather them)
 		]
-	, "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
+	& "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
-	, Apt.serviceInstalledRunning "openbsd-inetd"
+	& Apt.serviceInstalledRunning "openbsd-inetd"
-	, File.notPresent "/etc/cron.daily/leafnode"
+	& File.notPresent "/etc/cron.daily/leafnode"
-	, File.notPresent "/etc/cron.d/leafnode"
+	& File.notPresent "/etc/cron.d/leafnode"
-	, Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";"
+	& Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool expirecommand
+	& Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" uucpcommand
+	& Apache.siteEnabled "nntp.olduse.net" nntpcfg
+  where
+	newsspool = "/var/spool/news"
+	datadir = "/var/spool/oldusenet"
+	expirecommand = intercalate ";"
 		[ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60  -print | xargs --no-run-if-empty rm"
 		, "find -type d -empty | xargs --no-run-if-empty rmdir"
 		]
-	, Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $
+	uucpcommand = "/usr/bin/uucp " ++ datadir
-		"/usr/bin/uucp " ++ datadir
+	nntpcfg = apachecfg "nntp.olduse.net" False
-	, toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False
 		[ "  DocumentRoot " ++ datadir ++ "/"
 		, "  <Directory " ++ datadir ++ "/>"
 		, "    Options Indexes FollowSymlinks"
@@ -63,23 +64,25 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
 		, Apache.allowAll
 		, "  </Directory>"
 		]
-	]
-  where
-	newsspool = "/var/spool/news"
-	datadir = "/var/spool/oldusenet"
 
-oldUseNetShellBox :: Property
+	oldUseNetBackup = Obnam.backup datadir "33 4 * * *"
-oldUseNetShellBox = propertyList "olduse.net shellbox"
+		[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
-	[ oldUseNetInstalled "oldusenet"
+		, "--client-name=spool"
-	, Service.running "shellinabox"
+		] Obnam.OnlyClient
-	]
+		`requires` Ssh.keyImported SshRsa "root" (Context "olduse.net")
+		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
 
-oldUseNetInstalled :: Apt.Package -> Property
+oldUseNetShellBox :: Property HasInfo
+oldUseNetShellBox = propertyList "olduse.net shellbox" $ props
+	& oldUseNetInstalled "oldusenet"
+	& Service.running "shellinabox"
+
+oldUseNetInstalled :: Apt.Package -> Property HasInfo
 oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
-	propertyList ("olduse.net " ++ pkg)
+	propertyList ("olduse.net " ++ pkg) $ props
-		[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
+		& Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
 			`describe` "olduse.net build deps"
-		, scriptProperty
+		& scriptProperty
 			[ "rm -rf /root/tmp/oldusenet" -- idenpotency
 			, "git clone git://olduse.net/ /root/tmp/oldusenet/source"
 			, "cd /root/tmp/oldusenet/source/"
@@ -88,12 +91,15 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
 			, "apt-get -fy install" -- dependencies
 			, "rm -rf /root/tmp/oldusenet"
 			] `describe` "olduse.net built"
-		]
 
-
+kgbServer :: Property HasInfo
-kgbServer :: Property
+kgbServer = propertyList desc $ props
-kgbServer = propertyList desc
+	& installed
-	[ withOS desc $ \o -> case o of
+	& File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
+		`onChange` Service.restarted "kgb-bot"
+  where
+	desc = "kgb.kitenet.net setup"
+	installed = withOS desc $ \o -> case o of
 		(Just (System (Debian Unstable) _)) ->
 			ensureProperty $ propertyList desc
 				[ Apt.serviceInstalledRunning "kgb-bot"
@@ -102,28 +108,22 @@ kgbServer = propertyList desc
 					`onChange` Service.running "kgb-bot"
 				]
 		_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
-	, File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
-		`onChange` Service.restarted "kgb-bot"
-	]
-  where
-	desc = "kgb.kitenet.net setup"
 
-mumbleServer :: [Host] -> Property
+mumbleServer :: [Host] -> Property HasInfo
-mumbleServer hosts = combineProperties hn
+mumbleServer hosts = combineProperties hn $ props
-	[ Apt.serviceInstalledRunning "mumble-server"
+	& Apt.serviceInstalledRunning "mumble-server"
-	, Obnam.latestVersion
+	& Obnam.latestVersion
-	, Obnam.backup "/var/lib/mumble-server" "55 5 * * *"
+	& Obnam.backup "/var/lib/mumble-server" "55 5 * * *"
 		[ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam"
 		, "--client-name=mumble"
 		] Obnam.OnlyClient
 		`requires` Ssh.keyImported SshRsa "root" (Context hn)
 		`requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root"
-	, trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]
+	& trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"])
-	]
   where
 	hn = "mumble.debian.net"
 
-obnamLowMem :: Property
+obnamLowMem :: Property NoInfo
 obnamLowMem = combineProperties "obnam tuned for low memory use"
 	[ Obnam.latestVersion
 	, "/etc/obnam.conf" `File.containsLines`
@@ -135,10 +135,10 @@ obnamLowMem = combineProperties "obnam tuned for low memory use"
 	]
 
 -- git.kitenet.net and git.joeyh.name
-gitServer :: [Host] -> Property
+gitServer :: [Host] -> Property HasInfo
-gitServer hosts = propertyList "git.kitenet.net setup"
+gitServer hosts = propertyList "git.kitenet.net setup" $ props
-	[ Obnam.latestVersion
+	& Obnam.latestVersion
-	, Obnam.backupEncrypted "/srv/git" "33 3 * * *"
+	& Obnam.backupEncrypted "/srv/git" "33 3 * * *"
 		[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
 		, "--client-name=wren" -- historical
 		] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1")
@@ -146,14 +146,14 @@ gitServer hosts = propertyList "git.kitenet.net setup"
 		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
 		`requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net")
 		`requires` User.accountFor "family"
-	, Apt.installed ["git", "rsync", "gitweb"]
+	& Apt.installed ["git", "rsync", "gitweb"]
 	-- backport avoids channel flooding on branch merge
-	, Apt.installedBackport ["kgb-client"]
+	& Apt.installedBackport ["kgb-client"]
 	-- backport supports ssh event notification
-	, Apt.installedBackport ["git-annex"]
+	& Apt.installedBackport ["git-annex"]
-	, File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext
+	& File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext
-	, toProp $ Git.daemonRunning "/srv/git"
+	& Git.daemonRunning "/srv/git"
-	, "/etc/gitweb.conf" `File.containsLines`
+	& "/etc/gitweb.conf" `File.containsLines`
 		[ "$projectroot = '/srv/git';"
 		, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
 		, "# disable snapshot download; overloads server"
@@ -161,15 +161,14 @@ gitServer hosts = propertyList "git.kitenet.net setup"
 		]
 		`describe` "gitweb configured"
 	-- Repos push on to github.
-	, Ssh.knownHost hosts "github.com" "joey"
+	& Ssh.knownHost hosts "github.com" "joey"
 	-- I keep the website used for gitweb checked into git..
-	, Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+	& Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
-	, website "git.kitenet.net"
+	& website "git.kitenet.net"
-	, website "git.joeyh.name"
+	& website "git.joeyh.name"
-	, toProp $ Apache.modEnabled "cgi"
+	& Apache.modEnabled "cgi"
-	]
   where
-	website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True
+	website hn = apacheSite hn True
 		[ "  DocumentRoot /srv/web/git.kitenet.net/"
 		, "  <Directory /srv/web/git.kitenet.net/>"
 		, "    Options Indexes ExecCGI FollowSymlinks"
@@ -188,18 +187,17 @@ gitServer hosts = propertyList "git.kitenet.net setup"
 type AnnexUUID = String
 
 -- | A website, with files coming from a git-annex repository.
-annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property
+annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo
-annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex")
+annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props
-	[ Git.cloned "joey" origin dir Nothing
+	& Git.cloned "joey" origin dir Nothing
 		`onChange` setup
-	, alias hn
+	& alias hn
-	, postupdatehook `File.hasContent`
+	& postupdatehook `File.hasContent`
 		[ "#!/bin/sh"
 		, "exec git update-server-info"
 		] `onChange`
 			(postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes)))
-	, setupapache
+	& setupapache
-	]
   where
 	dir = "/srv/web/" ++ hn
 	postupdatehook = dir </> ".git/hooks/post-update"
@@ -212,7 +210,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
 		, "git update-server-info"
 		]
 	addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url
-	setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ 
+	setupapache = apacheSite hn True
 		[ "  ServerAlias www."++hn
 		, ""
 		, "  DocumentRoot /srv/web/"++hn
@@ -230,6 +228,9 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
 		, "  </Directory>"
 		]
 
+apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty
+apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle
+
 apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
 apachecfg hn withssl middle
 	| withssl = vhost False ++ vhost True
@@ -268,20 +269,19 @@ mainhttpscert True =
 	, "  SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
 	]
 		
-gitAnnexDistributor :: Property
+gitAnnexDistributor :: Property HasInfo
-gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer"
+gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
-	[ Apt.installed ["rsync"]
+	& Apt.installed ["rsync"]
-	, File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
+	& File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
 		`onChange` Service.restarted "rsync"
-	, File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor")
+	& File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor")
 		`onChange` Service.restarted "rsync"
-	, "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
+	& "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
 		`onChange` Service.running "rsync"
-	, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
+	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
-	, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"
+	& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"
 	-- git-annex distribution signing key
-	, Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey"
+	& Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey"
-	]
   where
 	endpoint d = combineProperties ("endpoint " ++ d)
 		[ File.dirExists d
@@ -289,50 +289,48 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
 		]
 
 -- Twitter, you kill us.
-twitRss :: Property
+twitRss :: Property HasInfo
-twitRss = combineProperties "twitter rss"
+twitRss = combineProperties "twitter rss" $ props
-	[ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing
+	& Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing
-	, check (not <$> doesFileExist (dir </> "twitRss")) $
+	& check (not <$> doesFileExist (dir </> "twitRss")) compiled
-		userScriptProperty "joey"
+	& feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
-			[ "cd " ++ dir
+	& feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
-			, "ghc --make twitRss" 
-			]
-			`requires` Apt.installed
-				[ "libghc-xml-dev"
-				, "libghc-feed-dev"
-				, "libghc-tagsoup-dev"
-				]
-	, feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
-	, feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
-	]
   where
 	dir = "/srv/web/tmp.kitenet.net/twitrss"
 	crontime = "15 * * * *"
 	feed url desc = Cron.job desc crontime "joey" dir $
 		"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
+	compiled = userScriptProperty "joey"
+		[ "cd " ++ dir
+		, "ghc --make twitRss" 
+		]
+		`requires` Apt.installed
+			[ "libghc-xml-dev"
+			, "libghc-feed-dev"
+			, "libghc-tagsoup-dev"
+			]
 
 -- Work around for expired ssl cert.
 -- (no longer expired, TODO remove this and change urls)
-pumpRss :: Property
+pumpRss :: Property NoInfo
 pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/"
 	"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null"
 
-ircBouncer :: Property
+ircBouncer :: Property HasInfo
-ircBouncer = propertyList "IRC bouncer"
+ircBouncer = propertyList "IRC bouncer" $ props
-	[ Apt.installed ["znc"]
+	& Apt.installed ["znc"]
-	, User.accountFor "znc"
+	& User.accountFor "znc"
-	, File.dirExists (takeDirectory conf)
+	& File.dirExists (takeDirectory conf)
-	, File.hasPrivContent conf anyContext
+	& File.hasPrivContent conf anyContext
-	, File.ownerGroup conf "znc" "znc"
+	& File.ownerGroup conf "znc" "znc"
-	, Cron.job "znconboot" "@reboot" "znc" "~" "znc"
+	& Cron.job "znconboot" "@reboot" "znc" "~" "znc"
 	-- ensure running if it was not already
-	, trivial $ userScriptProperty "znc" ["znc || true"]
+	& trivial (userScriptProperty "znc" ["znc || true"])
 		`describe` "znc running"
-	]
   where
 	conf = "/home/znc/.znc/configs/znc.conf"
 
-kiteShellBox :: Property
+kiteShellBox :: Property NoInfo
 kiteShellBox = propertyList "kitenet.net shellinabox"
 	[ Apt.installed ["shellinabox"]
 	, File.hasContent "/etc/default/shellinabox"
@@ -345,28 +343,34 @@ kiteShellBox = propertyList "kitenet.net shellinabox"
 	, Service.running "shellinabox"
 	]
 
-githubBackup :: Property
+githubBackup :: Property HasInfo
-githubBackup = propertyList "github-backup box"
+githubBackup = propertyList "github-backup box" $ props
-	[ Apt.installed ["github-backup", "moreutils"]
+	& Apt.installed ["github-backup", "moreutils"]
-	, let f = "/home/joey/.github-keys"
+	& githubKeys
-	  in File.hasPrivContent f anyContext
+	& Cron.niceJob "github-backup run" "30 4 * * *" "joey"
-		`onChange` File.ownerGroup f "joey" "joey"
+		"/home/joey/lib/backup" backupcmd
-	, Cron.niceJob "github-backup run" "30 4 * * *" "joey"
+	& Cron.niceJob "gitriddance" "30 4 * * *" "joey"
-		"/home/joey/lib/backup" $ intercalate "&&" $
+		"/home/joey/lib/backup" gitriddancecmd
-			[ "mkdir -p github"
-			, "cd github"
-			, ". $HOME/.github-keys"
-			, "github-backup joeyh"
-			]
-	, Cron.niceJob "gitriddance" "30 4 * * *" "joey"
-		"/home/joey/lib/backup" $ intercalate "&&" $
-			[ "cd github"
-			, ". $HOME/.github-keys"
-			] ++ map gitriddance githubMirrors
-	]
   where
+	backupcmd = intercalate "&&" $
+		[ "mkdir -p github"
+		, "cd github"
+		, ". $HOME/.github-keys"
+		, "github-backup joeyh"
+		]
+	gitriddancecmd = intercalate "&&" $
+		[ "cd github"
+		, ". $HOME/.github-keys"
+		] ++ map gitriddance githubMirrors
 	gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
 
+githubKeys :: Property HasInfo
+githubKeys = 
+	let f = "/home/joey/.github-keys"
+	in File.hasPrivContent f anyContext
+		`onChange` File.ownerGroup f "joey" "joey"
+
+
 -- these repos are only mirrored on github, I don't want
 -- all the proprietary features
 githubMirrors :: [(String, String)]
@@ -380,12 +384,12 @@ githubMirrors =
   where
 	plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests"
 
-rsyncNetBackup :: [Host] -> Property
+rsyncNetBackup :: [Host] -> Property NoInfo
 rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *"
 	"joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
 	`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "joey"
 
-backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property
+backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property NoInfo
 backupsBackedupTo hosts desthost destdir = Cron.niceJob desc
 	"1 1 * * 3" "joey" "/" cmd
 	`requires` Ssh.knownHost hosts desthost "joey"
@@ -393,7 +397,7 @@ backupsBackedupTo hosts desthost destdir = Cron.niceJob desc
 	desc = "backups copied to " ++ desthost ++ " weekly"
 	cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir
 
-obnamRepos :: [String] -> Property
+obnamRepos :: [String] -> Property NoInfo
 obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
 	(mkbase : map mkrepo rs)
   where
@@ -403,23 +407,22 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
 	mkdir d = File.dirExists d
 		`before` File.ownerGroup d "joey" "joey"
 
-podcatcher :: Property
+podcatcher :: Property NoInfo
 podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *"
 	"joey" "/home/joey/lib/sound/podcasts"
 	"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update"
 	`requires` Apt.installed ["git-annex", "myrepos"]
 
-kiteMailServer :: Property
+kiteMailServer :: Property HasInfo
-kiteMailServer = propertyList "kitenet.net mail server"
+kiteMailServer = propertyList "kitenet.net mail server" $ props
-	[ Postfix.installed
+	& Postfix.installed
-	, Apt.installed ["postfix-pcre"]
+	& Apt.installed ["postfix-pcre"]
-	, Apt.serviceInstalledRunning "postgrey"
+	& Apt.serviceInstalledRunning "postgrey"
 
-	, Apt.serviceInstalledRunning "spamassassin"
+	& Apt.serviceInstalledRunning "spamassassin"
-	, "/etc/default/spamassassin" `File.containsLines`
+	& "/etc/default/spamassassin" `File.containsLines`
 		[ "# Propellor deployed"
 		, "ENABLED=1"
-		, "CRON=1"
 		, "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\""
 		, "CRON=1"
 		, "NICE=\"--nicelevel 15\""
@@ -427,15 +430,15 @@ kiteMailServer = propertyList "kitenet.net mail server"
 		`describe` "spamd enabled"
 		`requires` Apt.serviceInstalledRunning "cron"
 	
-	, Apt.serviceInstalledRunning "spamass-milter"
+	& Apt.serviceInstalledRunning "spamass-milter"
 	-- Add -m to prevent modifying messages Subject or body.
-	, "/etc/default/spamass-milter" `File.containsLine`
+	& "/etc/default/spamass-milter" `File.containsLine`
 		"OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\""
 		`onChange` Service.restarted "spamass-milter"
 		`describe` "spamass-milter configured"
 	
-	, Apt.serviceInstalledRunning "amavisd-milter"
+	& Apt.serviceInstalledRunning "amavisd-milter"
-	, "/etc/default/amavisd-milter" `File.containsLines`
+	& "/etc/default/amavisd-milter" `File.containsLines`
 		[ "# Propellor deployed"
 		, "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock"
 		, "MILTERSOCKETOWNER=\"postfix:postfix\""
@@ -443,12 +446,12 @@ kiteMailServer = propertyList "kitenet.net mail server"
 		]
 		`onChange` Service.restarted "amavisd-milter"
 		`describe` "amavisd-milter configured for postfix"
-	, Apt.serviceInstalledRunning "clamav-freshclam"
+	& Apt.serviceInstalledRunning "clamav-freshclam"
 
-	, dkimInstalled
+	& dkimInstalled
 
-	, Apt.installed ["maildrop"]
+	& Apt.installed ["maildrop"]
-	, "/etc/maildroprc" `File.hasContent`
+	& "/etc/maildroprc" `File.hasContent`
 		[ "# Global maildrop filter file (deployed with propellor)"
 		, "DEFAULT=\"$HOME/Maildir\""
 		, "MAILBOX=\"$DEFAULT/.\""
@@ -462,19 +465,19 @@ kiteMailServer = propertyList "kitenet.net mail server"
 		]
 		`describe` "maildrop configured"
 
-	, "/etc/aliases" `File.hasPrivContentExposed` ctx
+	& "/etc/aliases" `File.hasPrivContentExposed` ctx
 		`onChange` Postfix.newaliases
-	, hasJoeyCAChain
+	& hasJoeyCAChain
-	, hasPostfixCert ctx
+	& hasPostfixCert ctx
 
-	, "/etc/postfix/mydomain" `File.containsLines`
+	& "/etc/postfix/mydomain" `File.containsLines`
 		[ "/.*\\.kitenet\\.net/\tOK"
 		, "/ikiwiki\\.info/\tOK"
 		, "/joeyh\\.name/\tOK"
 		]
 		`onChange` Postfix.reloaded
 		`describe` "postfix mydomain file configured"
-	, "/etc/postfix/obscure_client_relay.pcre" `File.hasContent`
+	& "/etc/postfix/obscure_client_relay.pcre" `File.hasContent`
 		-- Remove received lines for mails relayed from trusted
 		-- clients. These can be a privacy violation, or trigger
 		-- spam filters.
@@ -486,16 +489,16 @@ kiteMailServer = propertyList "kitenet.net mail server"
 		]
 		`onChange` Postfix.reloaded
 		`describe` "postfix obscure_client_relay file configured"
-	, Postfix.mappedFile "/etc/postfix/virtual"
+	& Postfix.mappedFile "/etc/postfix/virtual"
 		(flip File.containsLines
 			[ "# *@joeyh.name to joey"
 			, "@joeyh.name\tjoey"
 			]
 		) `describe` "postfix virtual file configured"
 		`onChange` Postfix.reloaded
-	, Postfix.mappedFile "/etc/postfix/relay_clientcerts" $
+	& Postfix.mappedFile "/etc/postfix/relay_clientcerts"
-		flip File.hasPrivContentExposed ctx
+		(flip File.hasPrivContentExposed ctx)
-	, Postfix.mainCfFile `File.containsLines`
+	& Postfix.mainCfFile `File.containsLines`
 		[ "myhostname = kitenet.net"
 		, "mydomain = $myhostname"
 		, "append_dot_mydomain = no"
@@ -544,24 +547,24 @@ kiteMailServer = propertyList "kitenet.net mail server"
 		`onChange` Postfix.reloaded
 		`describe` "postfix configured"
 	
-	, Apt.serviceInstalledRunning "dovecot-imapd"
+	& Apt.serviceInstalledRunning "dovecot-imapd"
-	, Apt.serviceInstalledRunning "dovecot-pop3d"
+	& Apt.serviceInstalledRunning "dovecot-pop3d"
-	, "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
+	& "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
 		"mail_location = maildir:~/Maildir"
 		`onChange` Service.reloaded "dovecot"
 		`describe` "dovecot mail.conf"
-	, "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine`
+	& "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine`
 		"!include auth-passwdfile.conf.ext"
 		`onChange` Service.restarted "dovecot"
 		`describe` "dovecot auth.conf"
-	, File.hasPrivContent dovecotusers ctx
+	& File.hasPrivContent dovecotusers ctx
 		`onChange` (dovecotusers `File.mode`
 			combineModes [ownerReadMode, groupReadMode])
-	, File.ownerGroup dovecotusers "root" "dovecot"
+	& File.ownerGroup dovecotusers "root" "dovecot"
 
-	, Apt.installed ["mutt", "bsd-mailx", "alpine"]
+	& Apt.installed ["mutt", "bsd-mailx", "alpine"]
 
-	, pinescript `File.hasContent`
+	& pinescript `File.hasContent`
 		[ "#!/bin/sh"
 		, "# deployed with propellor"
 		, "set -e"
@@ -575,14 +578,13 @@ kiteMailServer = propertyList "kitenet.net mail server"
 		`onChange` (pinescript `File.mode`
 			combineModes (readModes ++ executeModes))
 		`describe` "pine wrapper script"
-	, "/etc/pine.conf" `File.hasContent`
+	& "/etc/pine.conf" `File.hasContent`
 		[ "# deployed with propellor"
 		, "inbox-path={localhost/novalidate-cert/NoRsh}inbox"
 		]
 		`describe` "pine configured to use local imap server"
 	
-	, Apt.serviceInstalledRunning "mailman"
+	& Apt.serviceInstalledRunning "mailman"
-	]
   where
 	ctx = Context "kitenet.net"
 	pinescript = "/usr/local/bin/pine"
@@ -590,7 +592,7 @@ kiteMailServer = propertyList "kitenet.net mail server"
 
 -- Configures postfix to relay outgoing mail to kitenet.net, with
 -- verification via tls cert.
-postfixClientRelay :: Context -> Property
+postfixClientRelay :: Context -> Property HasInfo
 postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
 	[ "relayhost = kitenet.net"
 	, "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem"
@@ -606,7 +608,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
 	`requires` hasPostfixCert ctx
 
 -- Configures postfix to have the dkim milter, and no other milters.
-dkimMilter :: Property
+dkimMilter :: Property HasInfo
 dkimMilter = Postfix.mainCfFile `File.containsLines`
 	[ "smtpd_milters = inet:localhost:8891"
 	, "non_smtpd_milters = inet:localhost:8891"
@@ -619,22 +621,22 @@ dkimMilter = Postfix.mainCfFile `File.containsLines`
 
 -- This does not configure postfix to use the dkim milter,
 -- nor does it set up domainkey DNS.
-dkimInstalled :: Property
+dkimInstalled :: Property HasInfo
-dkimInstalled = propertyList "opendkim installed"
+dkimInstalled = go `onChange` Service.restarted "opendkim"
-	[ Apt.serviceInstalledRunning "opendkim"
+  where
-	, File.dirExists "/etc/mail"
+	go = propertyList "opendkim installed" $ props
-	, File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net")
+		& Apt.serviceInstalledRunning "opendkim"
-	, File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim"
+		& File.dirExists "/etc/mail"
-	, "/etc/default/opendkim" `File.containsLine`
+		& File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net")
-		"SOCKET=\"inet:8891@localhost\""
+		& File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim"
-	, "/etc/opendkim.conf" `File.containsLines`
+		& "/etc/default/opendkim" `File.containsLine`
-		[ "KeyFile /etc/mail/dkim.key"
+			"SOCKET=\"inet:8891@localhost\""
-		, "SubDomains yes"
+		& "/etc/opendkim.conf" `File.containsLines`
-		, "Domain *"
+			[ "KeyFile /etc/mail/dkim.key"
-		, "Selector mail"
+			, "SubDomains yes"
-		]
+			, "Domain *"
-	]
+			, "Selector mail"
-	`onChange` Service.restarted "opendkim"
+			]
 
 -- This is the dkim public key, corresponding with /etc/mail/dkim.key
 -- This value can be included in a domain's additional records to make
@@ -642,37 +644,36 @@ dkimInstalled = propertyList "opendkim installed"
 domainKey :: (BindDomain, Record)
 domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
 
-hasJoeyCAChain :: Property
+hasJoeyCAChain :: Property HasInfo
 hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
 	Context "joeyca.pem"
 
-hasPostfixCert :: Context -> Property
+hasPostfixCert :: Context -> Property HasInfo
 hasPostfixCert ctx = combineProperties "postfix tls cert installed"
 	[ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
 	, "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
 	]
 
-kitenetHttps :: Property
+kitenetHttps :: Property HasInfo
-kitenetHttps = propertyList "kitenet.net https certs"
+kitenetHttps = propertyList "kitenet.net https certs" $ props
-	[ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
+	& File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
-	, File.hasPrivContent "/etc/ssl/private/web.pem" ctx
+	& File.hasPrivContent "/etc/ssl/private/web.pem" ctx
-	, File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx
+	& File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx
-	, toProp $ Apache.modEnabled "ssl"
+	& Apache.modEnabled "ssl"
-	]
   where
 	ctx = Context "kitenet.net"
 
 -- Legacy static web sites and redirections from kitenet.net to newer
 -- sites.
-legacyWebSites :: Property
+legacyWebSites :: Property HasInfo
-legacyWebSites = propertyList "legacy web sites"
+legacyWebSites = propertyList "legacy web sites" $ props
-	[ Apt.serviceInstalledRunning "apache2"
+	& Apt.serviceInstalledRunning "apache2"
-	, toProp $ Apache.modEnabled "rewrite"
+	& Apache.modEnabled "rewrite"
-	, toProp $ Apache.modEnabled "cgi"
+	& Apache.modEnabled "cgi"
-	, toProp $ Apache.modEnabled "speling"
+	& Apache.modEnabled "speling"
-	, userDirHtml
+	& userDirHtml
-	, kitenetHttps
+	& kitenetHttps
-	, toProp $ Apache.siteEnabled "kitenet.net" $ apachecfg "kitenet.net" True
+	& apacheSite "kitenet.net" True
 		-- /var/www is empty
 		[ "DocumentRoot /var/www"
 		, "<Directory /var/www>"
@@ -759,8 +760,8 @@ legacyWebSites = propertyList "legacy web sites"
 		, "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]"
 		, "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]"
 		]
-	, alias "anna.kitenet.net"
+	& alias "anna.kitenet.net"
-	, toProp $ Apache.siteEnabled "anna.kitenet.net" $ apachecfg "anna.kitenet.net" False
+	& apacheSite "anna.kitenet.net" False
 		[ "DocumentRoot /home/anna/html"
 		, "<Directory /home/anna/html/>"
 		, "  Options Indexes ExecCGI"
@@ -768,9 +769,9 @@ legacyWebSites = propertyList "legacy web sites"
 		, Apache.allowAll
 		, "</Directory>"
 		]
-	, alias "sows-ear.kitenet.net"
+	& alias "sows-ear.kitenet.net"
-	, alias "www.sows-ear.kitenet.net"
+	& alias "www.sows-ear.kitenet.net"
-	, toProp $ Apache.siteEnabled "sows-ear.kitenet.net" $ apachecfg "sows-ear.kitenet.net" False
+	& apacheSite "sows-ear.kitenet.net" False
 		[ "ServerAlias www.sows-ear.kitenet.net"
 		, "DocumentRoot /srv/web/sows-ear.kitenet.net"
 		, "<Directory /srv/web/sows-ear.kitenet.net>"
@@ -779,9 +780,9 @@ legacyWebSites = propertyList "legacy web sites"
 		, Apache.allowAll
 		, "</Directory>"
 		]
-	, alias "wortroot.kitenet.net"
+	& alias "wortroot.kitenet.net"
-	, alias "www.wortroot.kitenet.net"
+	& alias "www.wortroot.kitenet.net"
-	, toProp $ Apache.siteEnabled "wortroot.kitenet.net" $ apachecfg "wortroot.kitenet.net" False
+	& apacheSite "wortroot.kitenet.net" False
 		[ "ServerAlias www.wortroot.kitenet.net"
 		, "DocumentRoot /srv/web/wortroot.kitenet.net"
 		, "<Directory /srv/web/wortroot.kitenet.net>"
@@ -790,8 +791,8 @@ legacyWebSites = propertyList "legacy web sites"
 		, Apache.allowAll
 		, "</Directory>"
 		]
-	, alias "creeksidepress.com"
+	& alias "creeksidepress.com"
-	, toProp $ Apache.siteEnabled "creeksidepress.com" $ apachecfg "creeksidepress.com" False
+	& apacheSite "creeksidepress.com" False
 		[ "ServerAlias www.creeksidepress.com"
 		, "DocumentRoot /srv/web/www.creeksidepress.com"
 		, "<Directory /srv/web/www.creeksidepress.com>"
@@ -800,8 +801,8 @@ legacyWebSites = propertyList "legacy web sites"
 		, Apache.allowAll
 		, "</Directory>"
 		]
-	, alias "joey.kitenet.net"
+	& alias "joey.kitenet.net"
-	, toProp $ Apache.siteEnabled "joey.kitenet.net" $ apachecfg "joey.kitenet.net" False
+	& apacheSite "joey.kitenet.net" False
 		[ "DocumentRoot /var/www"
 		, "<Directory /var/www/>"
 		, "  Options Indexes ExecCGI"
@@ -821,12 +822,12 @@ legacyWebSites = propertyList "legacy web sites"
 		, "# Redirect all to joeyh.name."
 		, "rewriterule (.*) http://joeyh.name$1 [r]"
 		]
-	]
 
-userDirHtml :: Property
+userDirHtml :: Property HasInfo
 userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
 	`onChange` Apache.reloaded
 	`requires` (toProp $ Apache.modEnabled "userdir")
   where
 	munge = replace "public_html" "html"
 	conf = "/etc/apache2/mods-available/userdir.conf"
+

src/Propellor/Property/Ssh.hs

@@ -1,4 +1,5 @@
 module Propellor.Property.Ssh (
+	PubKeyText,
 	setSshdConfig,
 	permitRootLogin,
 	passwordAuthentication,
@@ -35,7 +36,7 @@ sshBool False = "no"
 sshdConfig :: FilePath
 sshdConfig = "/etc/ssh/sshd_config"
 
-setSshdConfig :: String -> Bool -> Property
+setSshdConfig :: String -> Bool -> Property NoInfo
 setSshdConfig setting allowed = combineProperties "sshd config"
 	[ sshdConfig `File.lacksLine` (sshline $ not allowed)
 	, sshdConfig `File.containsLine` (sshline allowed)
@@ -45,10 +46,10 @@ setSshdConfig setting allowed = combineProperties "sshd config"
   where
 	sshline v = setting ++ " " ++ sshBool v
 
-permitRootLogin :: Bool -> Property
+permitRootLogin :: Bool -> Property NoInfo
 permitRootLogin = setSshdConfig "PermitRootLogin"
 
-passwordAuthentication :: Bool -> Property
+passwordAuthentication :: Bool -> Property NoInfo
 passwordAuthentication = setSshdConfig "PasswordAuthentication"
 
 dotDir :: UserName -> IO FilePath
@@ -66,13 +67,13 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys"
   where
 	go f = not . null <$> catchDefaultIO "" (readFile f)
 
-restarted :: Property
+restarted :: Property NoInfo
 restarted = Service.restarted "ssh"
 
 -- | Blows away existing host keys and make new ones.
 -- Useful for systems installed from an image that might reuse host keys.
 -- A flag file is used to only ever do this once.
-randomHostKeys :: Property
+randomHostKeys :: Property NoInfo
 randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 	`onChange` restarted
   where
@@ -89,7 +90,7 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 -- The corresponding private keys come from the privdata.
 --
 -- Any host keysthat are not in the list are removed from the host.
-hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property
+hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
 hostKeys ctx l = propertyList desc $ catMaybes $
 	map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
   where
@@ -100,19 +101,20 @@ hostKeys ctx l = propertyList desc $ catMaybes $
 	removestale b = map (File.notPresent . flip keyFile b) staletypes
 	cleanup
 		| null staletypes || null l = Nothing
-		| otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $
+		| otherwise = Just $ toProp $
-			ensureProperty $
+			property ("any other ssh host keys removed " ++ typelist staletypes) $
-				combineProperties desc (removestale True ++ removestale False)
+				ensureProperty $
-				`onChange` restarted
+					combineProperties desc (removestale True ++ removestale False)
+					`onChange` restarted
 
 -- | Installs a single ssh host key of a particular type.
 --
 -- The public key is provided to this function;
 -- the private key comes from the privdata; 
-hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property
+hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
 hostKey context keytype pub = combineProperties desc
 	[ pubKey keytype pub
-	, property desc $ install writeFile True pub
+	, toProp $ property desc $ install writeFile True pub
 	, withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
 		property desc $ getkey $ install writeFileProtected False
 	]
@@ -136,7 +138,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
 -- | Indicates the host key that is used by a Host, but does not actually
 -- configure the host to use it. Normally this does not need to be used;
 -- use 'hostKey' instead.
-pubKey :: SshKeyType -> PubKeyText -> Property
+pubKey :: SshKeyType -> PubKeyText -> Property HasInfo
 pubKey t k = pureInfoProperty ("ssh pubkey known") $
 	mempty { _sshPubKey = M.singleton t k }
 
@@ -145,7 +147,7 @@ getPubKey = asks (_sshPubKey . hostInfo)
 
 -- | Sets up a user with a ssh private key and public key pair from the
 -- PrivData.
-keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property
+keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property HasInfo
 keyImported keytype user context = combineProperties desc
 	[ installkey (SshPubKey keytype user) (install writeFile ".pub")
 	, installkey (SshPrivKey keytype user) (install writeFileProtected "")
@@ -178,7 +180,7 @@ fromKeyType SshEd25519 = "ed25519"
 
 -- | Puts some host's ssh public key(s), as set using 'pubKey',
 -- into the known_hosts file for a user.
-knownHost :: [Host] -> HostName -> UserName -> Property
+knownHost :: [Host] -> HostName -> UserName -> Property NoInfo
 knownHost hosts hn user = property desc $
 	go =<< fromHost hosts hn getPubKey
   where
@@ -198,7 +200,7 @@ knownHost hosts hn user = property desc $
 -- | Makes a user have authorized_keys from the PrivData
 --
 -- This removes any other lines from the file.
-authorizedKeys :: IsContext c => UserName -> c -> Property
+authorizedKeys :: IsContext c => UserName -> c -> Property HasInfo
 authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get ->
 	property (user ++ " has authorized_keys") $ get $ \v -> do
 		f <- liftIO $ dotFile "authorized_keys" user
@@ -212,7 +214,7 @@ authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \g
 
 -- | Ensures that a user's authorized_keys contains a line.
 -- Any other lines in the file are preserved as-is.
-authorizedKey :: UserName -> String -> Property
+authorizedKey :: UserName -> String -> Property NoInfo
 authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do
 	f <- liftIO $ dotFile "authorized_keys" user
 	ensureProperty $
@@ -225,7 +227,7 @@ authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do
 --
 -- Revert to prevent it listening on a particular port.
 listenPort :: Int -> RevertableProperty
-listenPort port = RevertableProperty enable disable
+listenPort port = enable <!> disable
   where
 	portline = "Port " ++ show port
 	enable = sshdConfig `File.containsLine` portline

src/Propellor/Property/Sudo.hs

@@ -9,7 +9,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 :: UserName -> Property NoInfo
 enabledFor user = property desc go `requires` Apt.installed ["sudo"]
   where
 	go = do

src/Propellor/Property/Systemd.hs

@@ -1,10 +1,16 @@
 module Propellor.Property.Systemd (
 	module Propellor.Property.Systemd.Core,
+	ServiceName,
+	MachineName,
 	started,
 	stopped,
 	enabled,
 	disabled,
+	restarted,
 	persistentJournal,
+	Option,
+	configured,
+	journaldConfigured,
 	daemonReloaded,
 	Container,
 	container,
@@ -33,33 +39,38 @@ type MachineName = String
 data Container = Container MachineName Chroot.Chroot Host
 	deriving (Show)
 
-instance Hostlike Container where
+instance PropAccum Container where
-        (Container n c h) & p = Container n c (h & p)
+	(Container n c h) & p = Container n c (h & p)
-        (Container n c h) &^ p = Container n c (h &^ p)
+	(Container n c h) &^ p = Container n c (h &^ p)
-        getHost (Container _ _ h) = h
+	getProperties (Container _ _ h) = hostProperties h
 
 -- | Starts a systemd service.
-started :: ServiceName -> Property
+started :: ServiceName -> Property NoInfo
 started n = trivial $ cmdProperty "systemctl" ["start", n]
 	`describe` ("service " ++ n ++ " started")
 
 -- | Stops a systemd service.
-stopped :: ServiceName -> Property
+stopped :: ServiceName -> Property NoInfo
 stopped n = trivial $ cmdProperty "systemctl" ["stop", n]
 	`describe` ("service " ++ n ++ " stopped")
 
 -- | Enables a systemd service.
-enabled :: ServiceName -> Property
+enabled :: ServiceName -> Property NoInfo
 enabled n = trivial $ cmdProperty "systemctl" ["enable", n]
 	`describe` ("service " ++ n ++ " enabled")
 
 -- | Disables a systemd service.
-disabled :: ServiceName -> Property
+disabled :: ServiceName -> Property NoInfo
 disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
 	`describe` ("service " ++ n ++ " disabled")
 
+-- | Restarts a systemd service.
+restarted :: ServiceName -> Property NoInfo
+restarted n = trivial $ cmdProperty "systemctl" ["restart", n]
+	`describe` ("service " ++ n ++ " restarted")
+
 -- | Enables persistent storage of the journal.
-persistentJournal :: Property
+persistentJournal :: Property NoInfo
 persistentJournal = check (not <$> doesDirectoryExist dir) $ 
 	combineProperties "persistent systemd journal"
 		[ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
@@ -70,8 +81,35 @@ persistentJournal = check (not <$> doesDirectoryExist dir) $
   where
 	dir = "/var/log/journal"
 
+type Option = String
+
+-- | Ensures that an option is configured in one of systemd's config files.
+-- Does not ensure that the relevant daemon notices the change immediately.
+--
+-- This assumes that there is only one [Header] per file, which is
+-- currently the case. And it assumes the file already exists with
+-- the right [Header], so new lines can just be appended to the end.
+configured :: FilePath -> Option -> String -> Property NoInfo
+configured cfgfile option value = combineProperties desc
+	[ File.fileProperty desc (mapMaybe removeother) cfgfile
+	, File.containsLine cfgfile line
+	]
+  where
+	setting = option ++ "="
+	line = setting ++ value
+	desc = cfgfile ++ " " ++ line
+	removeother l
+		| setting `isPrefixOf` l = Nothing
+		| otherwise = Just l
+
+-- | Configures journald, restarting it so the changes take effect.
+journaldConfigured :: Option -> String -> Property NoInfo
+journaldConfigured option value =
+	configured "/etc/systemd/journald.conf" option value
+		`onChange` restarted "systemd-journald"
+
 -- | Causes systemd to reload its configuration files.
-daemonReloaded :: Property
+daemonReloaded :: Property NoInfo
 daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
 
 -- | Defines a container with a given machine name.
@@ -105,17 +143,12 @@ container name mkchroot = Container name c h
 -- and deletes the chroot and all its contents.
 nspawned :: Container -> RevertableProperty
 nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
-	RevertableProperty setup teardown
+	p `describe` ("nspawned " ++ name)
   where
-	setup = combineProperties ("nspawned " ++ name) $
+	p = enterScript c
-		map toProp steps ++ [containerprovisioned]
+		`before` chrootprovisioned
-	teardown = combineProperties ("not nspawned " ++ name) $
+		`before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
-		map (toProp . revert) (reverse steps)
+		`before` containerprovisioned
-	steps =
-		[ enterScript c
-		, chrootprovisioned
-		, nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
-		]
 
 	-- Chroot provisioning is run in systemd-only mode,
 	-- which sets up the chroot and ensures systemd and dbus are
@@ -125,15 +158,17 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
 
 	-- Use nsenter to enter container and and run propellor to
 	-- finish provisioning.
-	containerprovisioned = Chroot.propellChroot chroot
+	containerprovisioned = 
-		(enterContainerProcess c) False
+		Chroot.propellChroot chroot (enterContainerProcess c) False
+			<!>
+		doNothing
 
 	chroot = Chroot.Chroot loc system builderconf h
 
 -- | Sets up the service file for the container, and then starts
 -- it running.
 nspawnService :: Container -> ChrootCfg -> RevertableProperty
-nspawnService (Container name _ _) cfg = RevertableProperty setup teardown
+nspawnService (Container name _ _) cfg = setup <!> teardown
   where
 	service = nspawnServiceName name
 	servicefile = "/etc/systemd/system/multi-user.target.wants" </> service
@@ -177,7 +212,7 @@ nspawnServiceParams (SystemdNspawnCfg ps) =
 -- This uses nsenter to enter the container, by looking up the pid of the
 -- container's init process and using its namespace.
 enterScript :: Container -> RevertableProperty
-enterScript c@(Container name _ _) = RevertableProperty setup teardown
+enterScript c@(Container name _ _) = setup <!> teardown
   where
 	setup = combineProperties ("generated " ++ enterScriptFile c)
 		[ scriptfile `File.hasContent`

src/Propellor/Property/Systemd/Core.hs

@@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt
 -- dbus is only a Recommends of systemd, but is needed for communication
 -- from the systemd inside a container to the one outside, so make sure it
 -- gets installed.
-installed :: Property
+installed :: Property NoInfo
 installed = Apt.installed ["systemd", "dbus"]

src/Propellor/Property/Tor.hs

@@ -10,7 +10,7 @@ import System.Posix.Files
 
 type HiddenServiceName = String
 
-isBridge :: Property
+isBridge :: Property NoInfo
 isBridge = setup `requires` Apt.installed ["tor"]
 	`describe` "tor bridge"
   where
@@ -21,7 +21,7 @@ isBridge = setup `requires` Apt.installed ["tor"]
 		, "Exitpolicy reject *:*"
 		] `onChange` restarted
 
-hiddenServiceAvailable :: HiddenServiceName -> Int -> Property
+hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
 hiddenServiceAvailable hn port = hiddenServiceHostName prop
   where
 	prop = mainConfig `File.containsLines`
@@ -30,13 +30,13 @@ hiddenServiceAvailable hn port = hiddenServiceHostName prop
 		]
 		`describe` "hidden service available"
 		`onChange` Service.reloaded "tor"
-	hiddenServiceHostName p =  adjustProperty p $ \satisfy -> do
+	hiddenServiceHostName p =  adjustPropertySatisfy p $ \satisfy -> do
 		r <- satisfy
 		h <- liftIO $ readFile (varLib </> hn </> "hostname")
 		warningMessage $ unwords ["hidden service hostname:", h]
 		return r
 
-hiddenService :: HiddenServiceName -> Int -> Property
+hiddenService :: HiddenServiceName -> Int -> Property NoInfo
 hiddenService hn port = mainConfig `File.containsLines`
 	[ unwords ["HiddenServiceDir", varLib </> hn]
 	, unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
@@ -44,7 +44,7 @@ hiddenService hn port = mainConfig `File.containsLines`
 	`describe` unwords ["hidden service available:", hn, show port]
 	`onChange` restarted
 
-hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property
+hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo
 hiddenServiceData hn context = combineProperties desc
 	[ installonion "hostname"
 	, installonion "private_key"
@@ -66,7 +66,7 @@ hiddenServiceData hn context = combineProperties desc
 			]
 		)
 
-restarted :: Property
+restarted :: Property NoInfo
 restarted = Service.restarted "tor"
 
 mainConfig :: FilePath

src/Propellor/Property/User.hs

@@ -6,7 +6,7 @@ import Propellor
 
 data Eep = YesReallyDeleteHome
 
-accountFor :: UserName -> Property
+accountFor :: UserName -> Property NoInfo
 accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
 	[ "--disabled-password"
 	, "--gecos", ""
@@ -15,7 +15,7 @@ accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdPropert
 	`describe` ("account for " ++ user)
 
 -- | Removes user home directory!! Use with caution.
-nuked :: UserName -> Eep -> Property
+nuked :: UserName -> Eep -> Property NoInfo
 nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel"
 	[ "-r"
 	, user
@@ -24,13 +24,13 @@ nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "use
 
 -- | Only ensures that the user has some password set. It may or may
 -- not be a password from the PrivData.
-hasSomePassword :: UserName -> Property
+hasSomePassword :: UserName -> Property HasInfo
 hasSomePassword user = hasSomePassword' user hostContext
 
 -- | While hasSomePassword uses the name of the host as context,
 -- this allows specifying a different context. This is useful when
 -- you want to use the same password on multiple hosts, for example.
-hasSomePassword' :: IsContext c => UserName -> c -> Property
+hasSomePassword' :: IsContext c => UserName -> c -> Property HasInfo
 hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
 	hasPassword' user context
 
@@ -40,10 +40,10 @@ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus us
 -- A user's password can be stored in the PrivData in either of two forms;
 -- the full cleartext <Password> or a <CryptPassword> hash. The latter
 -- is obviously more secure.
-hasPassword :: UserName -> Property
+hasPassword :: UserName -> Property HasInfo
 hasPassword user = hasPassword' user hostContext
 
-hasPassword' :: IsContext c => UserName -> c -> Property
+hasPassword' :: IsContext c => UserName -> c -> Property HasInfo
 hasPassword' user context = go `requires` shadowConfig True
   where
 	go = withSomePrivData srcs context $
@@ -66,7 +66,7 @@ setPassword getpassword = getpassword $ go
 			hPutStrLn h $ user ++ ":" ++ v
 			hClose h
 
-lockedPassword :: UserName -> Property
+lockedPassword :: UserName -> Property NoInfo
 lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
 	[ "--lock"
 	, user
@@ -90,7 +90,7 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
 homedir :: UserName -> IO FilePath
 homedir user = homeDirectory <$> getUserEntryForName user
 
-hasGroup :: UserName -> GroupName -> Property
+hasGroup :: UserName -> GroupName -> Property NoInfo
 hasGroup user group' = check test $ cmdProperty "adduser"
 	[ user
 	, group'
@@ -100,7 +100,7 @@ hasGroup user group' = check test $ cmdProperty "adduser"
 	test = not . elem group' . words <$> readProcess "groups" [user]
 
 -- | Controls whether shadow passwords are enabled or not.
-shadowConfig :: Bool -> Property
+shadowConfig :: Bool -> Property NoInfo
 shadowConfig True = check (not <$> shadowExists) $
 	cmdProperty "shadowconfig" ["on"]
 		`describe` "shadow passwords enabled"

src/Propellor/Spin.hs

@@ -24,6 +24,7 @@ import Propellor.PrivData.Paths
 import Propellor.Git
 import Propellor.Ssh
 import Propellor.Gpg
+import Propellor.Types.CmdLine
 import qualified Propellor.Shim as Shim
 import Utility.FileMode
 import Utility.SafeCommand

src/Propellor/Types.hs

@@ -1,44 +1,48 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Propellor.Types
 	( Host(..)
-	, Info(..)
-	, getInfo
-	, Propellor(..)
-	, Property(..)
-	, RevertableProperty(..)
-	, IsProp
-	, describe
-	, toProp
-	, requires
 	, Desc
-	, Result(..)
+	, Property
-	, ToResult(..)
+	, HasInfo
-	, ActionResult(..)
+	, NoInfo
-	, CmdLine(..)
+	, CInfo
-	, PrivDataField(..)
+	, infoProperty
-	, PrivData
+	, simpleProperty
-	, Context(..)
+	, adjustPropertySatisfy
-	, anyContext
+	, propertyInfo
-	, SshKeyType(..)
+	, propertyDesc
-	, Val(..)
+	, propertyChildren
-	, fromVal
+	, RevertableProperty(..)
-	, RunLog
+	, (<!>)
+	, IsProp(..)
+	, Combines(..)
+	, CombinedType
+	, before
+	, combineWith
+	, Info(..)
+	, Propellor(..)
 	, EndAction(..)
 	, module Propellor.Types.OS
 	, module Propellor.Types.Dns
+	, module Propellor.Types.Result
+	, propertySatisfy
+	, ignoreInfo
 	) where
 
 import Data.Monoid
 import Control.Applicative
-import System.Console.ANSI
-import System.Posix.Types
 import "mtl" Control.Monad.RWS.Strict
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
 import qualified Data.Set as S
 import qualified Data.Map as M
-import qualified Propellor.Types.Dns as Dns
 
 import Propellor.Types.OS
 import Propellor.Types.Chroot
@@ -46,137 +50,228 @@ import Propellor.Types.Dns
 import Propellor.Types.Docker
 import Propellor.Types.PrivData
 import Propellor.Types.Empty
+import Propellor.Types.Val
+import Propellor.Types.Result
+import qualified Propellor.Types.Dns as Dns
 
 -- | Everything Propellor knows about a system: Its hostname,
--- properties and other info.
+-- properties and their collected info.
 data Host = Host
 	{ hostName :: HostName
-	, hostProperties :: [Property]
+	, hostProperties :: [Property HasInfo]
 	, hostInfo :: Info
 	}
 	deriving (Show)
 
 -- | Propellor's monad provides read-only access to info about the host
--- it's running on, and a writer to accumulate logs about the run.
+-- it's running on, and a writer to accumulate EndActions.
-newtype Propellor p = Propellor { runWithHost :: RWST Host RunLog () IO p }
+newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
 	deriving
 		( Monad
 		, Functor
 		, Applicative
 		, MonadReader Host
-		, MonadWriter RunLog
+		, MonadWriter [EndAction]
 		, MonadIO
 		, MonadCatchIO
 		)
 
+instance Monoid (Propellor Result) where
+	mempty = return NoChange
+	-- | The second action is only run if the first action does not fail.
+	mappend x y = do
+		rx <- x
+		case rx of
+			FailedChange -> return FailedChange
+			_ -> do
+				ry <- y
+				return (rx <> ry)
+
+-- | An action that Propellor runs at the end, after trying to satisfy all
+-- properties. It's passed the combined Result of the entire Propellor run.
+data EndAction = EndAction Desc (Result -> Propellor Result)
+
+type Desc = String
+
 -- | The core data type of Propellor, this represents a property
 -- that the system should have, and an action to ensure it has the
 -- property.
-data Property = Property
+data Property i where
-	{ propertyDesc :: Desc
+	IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
-	, propertySatisfy :: Propellor Result
+	SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
-	-- ^ must be idempotent; may run repeatedly
-	, propertyInfo :: Info
-	-- ^ a property can add info to the host.
-	}
 
-instance Show Property where
+-- | Indicates that a Property has associated Info.
-	show p = "property " ++ show (propertyDesc p)
+data HasInfo
+-- | Indicates that a Property does not have Info.
+data NoInfo
+
+-- | Type level calculation of the combination of HasInfo and/or NoInfo
+type family CInfo x y
+type instance CInfo HasInfo HasInfo = HasInfo
+type instance CInfo HasInfo NoInfo = HasInfo
+type instance CInfo NoInfo HasInfo = HasInfo
+type instance CInfo NoInfo NoInfo = NoInfo
+
+-- | Constructs a Property with associated Info.
+infoProperty 
+	:: Desc -- ^ description of the property
+	-> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
+	-> Info -- ^ info associated with the property
+	-> [Property i] -- ^ child properties
+	-> Property HasInfo
+infoProperty d a i cs = IProperty d a i (map toIProperty cs)
+
+-- | Constructs a Property with no Info.
+simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
+simpleProperty = SProperty
+
+toIProperty :: Property i -> Property HasInfo
+toIProperty p@(IProperty {}) = p
+toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs)
+
+toSProperty :: Property i -> Property NoInfo
+toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs)
+toSProperty p@(SProperty {}) = p
+
+-- | Makes a version of a Proprty without its Info.
+-- Use with caution!
+ignoreInfo :: Property i -> Property NoInfo
+ignoreInfo = toSProperty
+
+-- | Gets the action that can be run to satisfy a Property.
+-- You should never run this action directly. Use
+-- 'Propellor.Engine.ensureProperty` instead.
+propertySatisfy :: Property i -> Propellor Result
+propertySatisfy (IProperty _ a _ _) = a
+propertySatisfy (SProperty _ a _) = a
+
+instance Show (Property i) where
+        show p = "property " ++ show (propertyDesc p)
+
+-- | Changes the action that is performed to satisfy a property. 
+adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
+adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
+adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs
+
+propertyInfo :: Property i -> Info
+propertyInfo (IProperty _ _ i _) = i
+propertyInfo (SProperty {}) = mempty
+
+propertyDesc :: Property i -> Desc
+propertyDesc (IProperty d _ _ _) = d
+propertyDesc (SProperty d _ _) = d
+
+-- | A Property can include a list of child properties that it also
+-- satisfies. This allows them to be introspected to collect their info, etc.
+propertyChildren :: Property i -> [Property i]
+propertyChildren (IProperty _ _ _ cs) = cs
+propertyChildren (SProperty _ _ cs) = cs
 
 -- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
+data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo)
+
+-- | Makes a revertable property; the first Property is run
+-- normally and the second is run when it's reverted.
+(<!>) :: Property i1 -> Property i2 -> RevertableProperty
+p1 <!> p2 = RevertableProperty (toIProperty p1) (toIProperty p2)
 
 class IsProp p where
 	-- | Sets description.
 	describe :: p -> Desc -> p
-	toProp :: p -> Property
+	toProp :: p -> Property HasInfo
-	-- | Indicates that the first property can only be satisfied
+	getDesc :: p -> Desc
-	-- once the second one is.
+	-- | Gets the info of the property, combined with all info
-	requires :: p -> Property -> p
+	-- of all children properties.
-	getInfo :: p -> Info
+	getInfoRecursive :: p -> Info
 
-instance IsProp Property where
+instance IsProp (Property HasInfo) where
-	describe p d = p { propertyDesc = d }
+	describe (IProperty _ a i cs) d = IProperty d a i cs
-	toProp p = p
+	toProp = id
-	getInfo = propertyInfo
+	getDesc = propertyDesc
-	x `requires` y = Property (propertyDesc x) satisfy info
+	getInfoRecursive (IProperty _ _ i cs) = 
-	  where
+		i <> mconcat (map getInfoRecursive cs)
-		info = getInfo y <> getInfo x
+instance IsProp (Property NoInfo) where
-		satisfy = do
+	describe (SProperty _ a cs) d = SProperty d a cs
-			r <- propertySatisfy y
+	toProp = toIProperty
-			case r of
+	getDesc = propertyDesc
-				FailedChange -> return FailedChange
+	getInfoRecursive _ = mempty
-				_ -> propertySatisfy x
-			
 
 instance IsProp RevertableProperty where
 	-- | Sets the description of both sides.
 	describe (RevertableProperty p1 p2) d = 
 		RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
+	getDesc (RevertableProperty p1 _) = getDesc p1
 	toProp (RevertableProperty p1 _) = p1
-	(RevertableProperty p1 p2) `requires` y =
-		RevertableProperty (p1 `requires` y) p2
 	-- | Return the Info of the currently active side.
-	getInfo (RevertableProperty p1 _p2) = getInfo p1
+	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
 
-type Desc = String
+-- | Type level calculation of the type that results from combining two types
+-- with `requires`.
+type family CombinedType x y
+type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
+type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty
+type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty
+type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty
 
-data Result = NoChange | MadeChange | FailedChange
+class Combines x y where
-	deriving (Read, Show, Eq)
+	-- | Indicates that the first property depends on the second,
+	-- so before the first is ensured, the second will be ensured.
+	requires :: x -> y -> CombinedType x y
+	
+-- | Combines together two properties, resulting in one property
+-- that ensures the first, and if the first succeeds, ensures the second.
+-- The property uses the description of the first property.
+before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x
+before x y = (y `requires` x) `describe` (getDesc x)
 
-instance Monoid Result where
+-- | Combines together two properties, yielding a property that
-	mempty = NoChange
+-- has the description and info of the first, and that has the second
+-- property as a child. The two actions to satisfy the properties
+-- are passed to a function that can combine them in arbitrary ways.
+combineWith
+	:: (Combines (Property x) (Property y))
+	=> (Propellor Result -> Propellor Result -> Propellor Result)
+	-> Property x
+	-> Property y
+	-> CombinedType (Property x) (Property y)
+combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ ->
+	f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y)
 
-	mappend FailedChange _ = FailedChange
+instance Combines (Property HasInfo) (Property HasInfo) where
-	mappend _ FailedChange = FailedChange
+	requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
-	mappend MadeChange _ = MadeChange
+		IProperty d1 (a2 <> a1) i1 (y : cs1)
-	mappend _ MadeChange = MadeChange
-	mappend NoChange NoChange = NoChange
 
-class ToResult t where
+instance Combines (Property HasInfo) (Property NoInfo) where
-	toResult :: t -> Result
+	requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
+		IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)
 
-instance ToResult Bool where
+instance Combines (Property NoInfo) (Property HasInfo) where
-	toResult False = FailedChange
+	requires (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
-	toResult True = MadeChange
+		IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1)
 
--- | Results of actions, with color.
+instance Combines (Property NoInfo) (Property NoInfo) where
-class ActionResult a where
+	requires (SProperty d1 a1  cs1) y@(SProperty _d2 a2 _cs2) =
-	getActionResult :: a -> (String, ColorIntensity, Color)
+		SProperty d1 (a2 <> a1) (y : cs1)
 
-instance ActionResult Bool where
+instance Combines RevertableProperty (Property HasInfo) where
-	getActionResult False = ("failed", Vivid, Red)
+	requires (RevertableProperty p1 p2) y =
-	getActionResult True = ("done", Dull, Green)
+		RevertableProperty (p1 `requires` y) p2
 
-instance ActionResult Result where
+instance Combines RevertableProperty (Property NoInfo) where
-	getActionResult NoChange = ("ok", Dull, Green)
+	requires (RevertableProperty p1 p2) y =
-	getActionResult MadeChange = ("done", Vivid, Green)
+		RevertableProperty (p1 `requires` toIProperty y) p2
-	getActionResult FailedChange = ("failed", Vivid, Red)
 
-data CmdLine
+instance Combines RevertableProperty RevertableProperty where
-	= Run HostName
+	requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) =
-	| Spin [HostName] (Maybe HostName)
+		RevertableProperty
-	| SimpleRun HostName
+			(x1 `requires` y1)
-	| Set PrivDataField Context
+			-- when reverting, run actions in reverse order
-	| Dump PrivDataField Context
+			(y2 `requires` x2)
-	| Edit PrivDataField Context
-	| ListFields
-	| AddKey String
-	| Merge
-	| Serialized CmdLine
-	| Continue CmdLine
-	| Update (Maybe HostName)
-	| Relay HostName
-	| DockerInit HostName
-	| DockerChain HostName String
-	| ChrootChain HostName FilePath Bool Bool
-	| GitPush Fd Fd
-	deriving (Read, Show, Eq)
 
 -- | Information about a host.
 data Info = Info
 	{ _os :: Val System
-	, _privDataFields :: S.Set (PrivDataField, HostContext)
+	, _privData :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext)
 	, _sshPubKey :: M.Map SshKeyType String
 	, _aliases :: S.Set HostName
 	, _dns :: S.Set Dns.Record
@@ -190,7 +285,7 @@ instance Monoid Info where
 	mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty
 	mappend old new = Info
 		{ _os = _os old <> _os new
-		, _privDataFields = _privDataFields old <> _privDataFields new
+		, _privData = _privData old <> _privData new
 		, _sshPubKey = _sshPubKey new `M.union` _sshPubKey old
 		, _aliases = _aliases old <> _aliases new
 		, _dns = _dns old <> _dns new
@@ -202,7 +297,7 @@ instance Monoid Info where
 instance Empty Info where
 	isEmpty i = and
 		[ isEmpty (_os i)
-		, isEmpty (_privDataFields i)
+		, isEmpty (_privData i)
 		, isEmpty (_sshPubKey i)
 		, isEmpty (_aliases i)
 		, isEmpty (_dns i)
@@ -210,26 +305,3 @@ instance Empty Info where
 		, isEmpty (_dockerinfo i)
 		, isEmpty (_chrootinfo i)
 		]
-
-data Val a = Val a | NoVal
-	deriving (Eq, Show)
-
-instance Monoid (Val a) where
-	mempty = NoVal
-	mappend old new = case new of
-		NoVal -> old
-		_ -> new
-
-instance Empty (Val a) where
-	isEmpty NoVal = True
-	isEmpty _ = False
-
-fromVal :: Val a -> Maybe a
-fromVal (Val a) = Just a
-fromVal NoVal = Nothing
-
-type RunLog = [EndAction]
-
--- | An action that Propellor runs at the end, after trying to satisfy all
--- properties. It's passed the combined Result of the entire Propellor run.
-data EndAction = EndAction Desc (Result -> Propellor Result)

src/Propellor/Types/CmdLine.hs

@@ -0,0 +1,27 @@
+module Propellor.Types.CmdLine where
+
+import Propellor.Types.OS
+import Propellor.Types.PrivData
+
+import System.Posix.Types
+
+data CmdLine
+	= Run HostName
+	| Spin [HostName] (Maybe HostName)
+	| SimpleRun HostName
+	| Set PrivDataField Context
+	| Dump PrivDataField Context
+	| Edit PrivDataField Context
+	| ListFields
+	| AddKey String
+	| Merge
+	| Serialized CmdLine
+	| Continue CmdLine
+	| Update (Maybe HostName)
+	| Relay HostName
+	| DockerInit HostName
+	| DockerChain HostName String
+	| ChrootChain HostName FilePath Bool Bool
+	| GitPush Fd Fd
+	deriving (Read, Show, Eq)
+

src/Propellor/Types/PrivData.hs

@@ -24,9 +24,11 @@ data PrivDataSource
 	| PrivDataSourceFileFromCommand PrivDataField FilePath String
 	| PrivDataSource PrivDataField String
 
+type PrivDataSourceDesc = String
+
 class IsPrivDataSource s where
 	privDataField :: s -> PrivDataField
-	describePrivDataSource :: s -> Maybe String
+	describePrivDataSource :: s -> Maybe PrivDataSourceDesc
 
 instance IsPrivDataSource PrivDataField where
 	privDataField = id

src/Propellor/Types/Result.hs

@@ -0,0 +1,37 @@
+module Propellor.Types.Result where
+
+import Data.Monoid
+import System.Console.ANSI
+
+-- | There can be three results of satisfying a Property.
+data Result = NoChange | MadeChange | FailedChange
+	deriving (Read, Show, Eq)
+
+instance Monoid Result where
+	mempty = NoChange
+
+	mappend FailedChange _ = FailedChange
+	mappend _ FailedChange = FailedChange
+	mappend MadeChange _ = MadeChange
+	mappend _ MadeChange = MadeChange
+	mappend NoChange NoChange = NoChange
+
+class ToResult t where
+	toResult :: t -> Result
+
+instance ToResult Bool where
+	toResult False = FailedChange
+	toResult True = MadeChange
+
+-- | Results of actions, with color.
+class ActionResult a where
+	getActionResult :: a -> (String, ColorIntensity, Color)
+
+instance ActionResult Bool where
+	getActionResult False = ("failed", Vivid, Red)
+	getActionResult True = ("done", Dull, Green)
+
+instance ActionResult Result where
+	getActionResult NoChange = ("ok", Dull, Green)
+	getActionResult MadeChange = ("done", Vivid, Green)
+	getActionResult FailedChange = ("failed", Vivid, Red)

src/Propellor/Types/Val.hs

@@ -0,0 +1,22 @@
+module Propellor.Types.Val where
+
+import Data.Monoid
+
+import Propellor.Types.Empty
+
+data Val a = Val a | NoVal
+	deriving (Eq, Show)
+
+instance Monoid (Val a) where
+	mempty = NoVal
+	mappend old new = case new of
+		NoVal -> old
+		_ -> new
+
+instance Empty (Val a) where
+	isEmpty NoVal = True
+	isEmpty _ = False
+
+fromVal :: Val a -> Maybe a
+fromVal (Val a) = Just a
+fromVal NoVal = Nothing

src/Utility/DataUnits.hs

@@ -0,0 +1,161 @@
+{- data size display and parsing
+ -
+ - Copyright 2011 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -
+ -
+ - And now a rant: 
+ -
+ - In the beginning, we had powers of two, and they were good.
+ -
+ - Disk drive manufacturers noticed that some powers of two were
+ - sorta close to some powers of ten, and that rounding down to the nearest
+ - power of ten allowed them to advertise their drives were bigger. This
+ - was sorta annoying.
+ -
+ - Then drives got big. Really, really big. This was good.
+ -
+ - Except that the small rounding error perpretrated by the drive
+ - manufacturers suffered the fate of a small error, and became a large
+ - error. This was bad.
+ -
+ - So, a committee was formed. And it arrived at a committee-like decision,
+ - which satisfied noone, confused everyone, and made the world an uglier
+ - place. As with all committees, this was meh.
+ -
+ - And the drive manufacturers happily continued selling drives that are
+ - increasingly smaller than you'd expect, if you don't count on your
+ - fingers. But that are increasingly too big for anyone to much notice.
+ - This caused me to need git-annex.
+ -
+ - Thus, I use units here that I loathe. Because if I didn't, people would
+ - be confused that their drives seem the wrong size, and other people would
+ - complain at me for not being standards compliant. And we call this
+ - progress?
+ -}
+
+module Utility.DataUnits (
+	dataUnits,
+	storageUnits,
+	memoryUnits,
+	bandwidthUnits,
+	oldSchoolUnits,
+	Unit(..),
+
+	roughSize,
+	compareSizes,
+	readSize
+) where
+
+import Data.List
+import Data.Char
+
+import Utility.HumanNumber
+
+type ByteSize = Integer
+type Name = String
+type Abbrev = String
+data Unit = Unit ByteSize Abbrev Name
+	deriving (Ord, Show, Eq)
+
+dataUnits :: [Unit]
+dataUnits = storageUnits ++ memoryUnits
+
+{- Storage units are (stupidly) powers of ten. -}
+storageUnits :: [Unit]
+storageUnits =
+	[ Unit (p 8) "YB" "yottabyte"
+	, Unit (p 7) "ZB" "zettabyte"
+	, Unit (p 6) "EB" "exabyte"
+	, Unit (p 5) "PB" "petabyte"
+	, Unit (p 4) "TB" "terabyte"
+	, Unit (p 3) "GB" "gigabyte"
+	, Unit (p 2) "MB" "megabyte"
+	, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
+	, Unit (p 0) "B" "byte"
+	]
+  where
+	p :: Integer -> Integer
+	p n = 1000^n
+
+{- Memory units are (stupidly named) powers of 2. -}
+memoryUnits :: [Unit]
+memoryUnits =
+	[ Unit (p 8) "YiB" "yobibyte"
+	, Unit (p 7) "ZiB" "zebibyte"
+	, Unit (p 6) "EiB" "exbibyte"
+	, Unit (p 5) "PiB" "pebibyte"
+	, Unit (p 4) "TiB" "tebibyte"
+	, Unit (p 3) "GiB" "gibibyte"
+	, Unit (p 2) "MiB" "mebibyte"
+	, Unit (p 1) "KiB" "kibibyte"
+	, Unit (p 0) "B" "byte"
+	]
+  where
+	p :: Integer -> Integer
+	p n = 2^(n*10)
+
+{- Bandwidth units are only measured in bits if you're some crazy telco. -}
+bandwidthUnits :: [Unit]
+bandwidthUnits = error "stop trying to rip people off"
+
+{- Do you yearn for the days when men were men and megabytes were megabytes? -}
+oldSchoolUnits :: [Unit]
+oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
+  where
+	mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
+
+{- approximate display of a particular number of bytes -}
+roughSize :: [Unit] -> Bool -> ByteSize -> String
+roughSize units short i
+	| i < 0 = '-' : findUnit units' (negate i)
+	| otherwise = findUnit units' i
+  where
+	units' = sortBy (flip compare) units -- largest first
+
+	findUnit (u@(Unit s _ _):us) i'
+		| i' >= s = showUnit i' u
+		| otherwise = findUnit us i'
+	findUnit [] i' = showUnit i' (last units') -- bytes
+
+	showUnit x (Unit size abbrev name) = s ++ " " ++ unit
+	  where
+		v = (fromInteger x :: Double) / fromInteger size
+		s = showImprecise 2 v
+		unit
+			| short = abbrev
+			| s == "1" = name
+			| otherwise = name ++ "s"
+
+{- displays comparison of two sizes -}
+compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String
+compareSizes units abbrev old new
+	| old > new = roughSize units abbrev (old - new) ++ " smaller"
+	| old < new = roughSize units abbrev (new - old) ++ " larger"
+	| otherwise = "same"
+
+{- Parses strings like "10 kilobytes" or "0.5tb". -}
+readSize :: [Unit] -> String -> Maybe ByteSize
+readSize units input
+	| null parsednum || null parsedunit = Nothing
+	| otherwise = Just $ round $ number * fromIntegral multiplier
+  where
+	(number, rest) = head parsednum
+	multiplier = head parsedunit
+	unitname = takeWhile isAlpha $ dropWhile isSpace rest
+
+	parsednum = reads input :: [(Double, String)]
+	parsedunit = lookupUnit units unitname
+
+	lookupUnit _ [] = [1] -- no unit given, assume bytes
+	lookupUnit [] _ = []
+	lookupUnit (Unit s a n:us) v
+		| a ~~ v || n ~~ v = [s]
+		| plural n ~~ v || a ~~ byteabbrev v = [s]
+		| otherwise = lookupUnit us v
+		
+	a ~~ b = map toLower a == map toLower b
+		
+	plural n = n ++ "s"
+	byteabbrev a = a ++ "b"

src/Utility/HumanNumber.hs

@@ -0,0 +1,21 @@
+{- numbers for humans
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.HumanNumber where
+
+{- Displays a fractional value as a string with a limited number
+ - of decimal digits. -}
+showImprecise :: RealFrac a => Int -> a -> String
+showImprecise precision n
+	| precision == 0 || remainder == 0 = show (round n :: Integer)
+	| otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)
+  where
+	int :: Integer
+	(int, frac) = properFraction n
+	remainder = round (frac * 10 ^ precision) :: Integer
+	pad0s s = replicate (precision - length s) '0' ++ s
+	striptrailing0s = reverse . dropWhile (== '0') . reverse

src/Utility/Table.hs

@@ -16,13 +16,14 @@ tableWithHeader header rows = header : map linesep header : rows
   where
 	linesep = map (const '-')
 
--- | Formats a table to lines, automatically padding rows to the same size.
+-- | Formats a table to lines, automatically padding columns to the same size.
 formatTable :: Table -> [String]
-formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table
+formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table
   where
 	pad (cell, size) = cell ++ take (size - length cell) padding
 	padding = repeat ' '
-	rowsizes = sumrows (map (map length) table)
+	colsizes = reverse $ (0:) $ drop 1 $ reverse $
-	sumrows [] = repeat 0
+		sumcols (map (map length) table)
-	sumrows [r] = r
+	sumcols [] = repeat 0
-	sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs
+	sumcols [r] = r
+	sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs