got rid of the Attr -> Attr SetAttr hack, and use monoids for Attr

The SetAttr hack used to be needed because the hostname was part of the
Attr, and was required to be present. Now that it's moved to Host, let's
get rid of that, since it tended to waste CPU.

src/Propellor/Attr.hs

@@ -9,9 +9,10 @@ import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
 import qualified Data.Map as M
 import Data.Maybe
+import Data.Monoid
 import Control.Applicative
 
-pureAttrProperty :: Desc -> SetAttr -> Property 
+pureAttrProperty :: Desc -> Attr -> Property 
 pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
 
 getHostName :: Propellor HostName
@@ -19,7 +20,7 @@ getHostName = asks _hostName
 
 os :: System -> Property
 os system = pureAttrProperty ("Operating " ++ show system) $
-	\d -> d { _os = Just system }
+	mempty { _os = Just system }
 
 getOS :: Propellor (Maybe System)
 getOS = asks (_os . hostAttr)
@@ -41,7 +42,7 @@ alias = addDNS . CNAME . AbsDomain
 
 addDNS :: Record -> Property
 addDNS r = pureAttrProperty (rdesc r) $
-	\d -> d { _dns = S.insert r (_dns d) }
+	mempty { _dns = S.singleton r }
   where
 	rdesc (CNAME d) = unwords ["alias", ddesc d]
 	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
@@ -55,32 +56,15 @@ addDNS r = pureAttrProperty (rdesc r) $
 	ddesc (RelDomain domain) = domain
 	ddesc RootDomain = "@"
 
--- | Adds a DNS NamedConf stanza.
---
--- Note that adding a Master stanza for a domain always overrides an
--- existing Secondary stanza, while a Secondary stanza is only added
--- when there is no existing Master stanza.
-addNamedConf :: NamedConf -> SetAttr
-addNamedConf conf d = d { _namedconf = new }
-  where
-	m = _namedconf d
-	domain = confDomain conf
-	new = case (confDnsServerType conf, confDnsServerType <$> M.lookup domain m) of
-		(Secondary, Just Master) -> m
-		_  -> M.insert domain conf m
-
-getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks (_namedconf . hostAttr)
-
 sshPubKey :: String -> Property
 sshPubKey k = pureAttrProperty ("ssh pubkey known") $
-	\d -> d { _sshPubKey = Just k }
+	mempty { _sshPubKey = Just k }
 
 getSshPubKey :: Propellor (Maybe String)
 getSshPubKey = asks (_sshPubKey . hostAttr)
 
 hostAttr :: Host -> Attr
-hostAttr (Host _ _ mkattrs) = mkattrs newAttr
+hostAttr (Host _ _ attr) = attr
 
 hostProperties :: Host -> [Property]
 hostProperties (Host _ ps _) = ps

src/Propellor/Engine.hs

@@ -20,7 +20,7 @@ runPropellor host a = runReaderT (runWithHost a) host
 mainProperties :: Host -> IO ()
 mainProperties host = do
 	r <- runPropellor host $
-		ensureProperties [Property "overall" (ensureProperties $ hostProperties host) id]
+		ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
 	setTitle "propellor: done"
 	hFlush stdout
 	case r of

src/Propellor/Property.hs

@@ -5,12 +5,10 @@ module Propellor.Property where
 import System.Directory
 import Control.Monad
 import Data.Monoid
-import Data.List
 import Control.Monad.IfElse
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
-import Propellor.Types.Attr
 import Propellor.Attr
 import Propellor.Engine
 import Utility.Monad
@@ -18,19 +16,19 @@ import System.FilePath
 
 -- Constructs a Property.
 property :: Desc -> Propellor Result -> Property
-property d s = Property d s id
+property d s = Property 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) (combineSetAttrs ps)
+propertyList desc ps = Property desc (ensureProperties ps) (combineAttrs ps)
 
 -- | Combines a list of properties, resulting in one property that
 -- ensures each in turn, stopping on failure.
 combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)
+combineProperties desc ps = Property desc (go ps NoChange) (combineAttrs ps)
   where
   	go [] rs = return rs
 	go (l:ls) rs = do
@@ -69,7 +67,7 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
 --- | Whenever a change has to be made for a Property, causes a hook
 -- Property to also be run, but not otherwise.
 onChange :: Property -> Property -> Property
-p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)
+p `onChange` hook = Property (propertyDesc p) satisfy (combineAttr p hook)
   where
 	satisfy = do
 		r <- ensureProperty p
@@ -130,21 +128,19 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
 -- > 	! oldproperty
 -- > 	& otherproperty
 host :: HostName -> Host
-host hn = Host hn [] (\_ -> newAttr)
+host hn = Host hn [] mempty
 
 -- | Adds a property to a Host
 --
 -- Can add Properties and RevertableProperties
 (&) :: IsProp p => Host -> p -> Host
-(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (setAttr p . as)
+(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (as <> getAttr p)
 
 infixl 1 &
 
 -- | Adds a property to the Host in reverted form.
 (!) :: Host -> RevertableProperty -> Host
-(Host hn ps as) ! p = Host hn (ps ++ [toProp q]) (setAttr q . as)
+h ! p = h & revert p
-  where
-	q = revert p
 
 infixl 1 !
 
@@ -152,12 +148,12 @@ infixl 1 !
 adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
 adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
 
--- Combines the Attr settings of two properties.
+-- Combines the Attr of two properties.
-combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr
+combineAttr :: (IsProp p, IsProp q) => p -> q -> Attr
-combineSetAttr p q = setAttr p . setAttr q
+combineAttr p q = getAttr p <> getAttr q
 
-combineSetAttrs :: IsProp p => [p] -> SetAttr
+combineAttrs :: IsProp p => [p] -> Attr
-combineSetAttrs = foldl' (.) id . map setAttr
+combineAttrs = mconcat . map getAttr
 
 makeChange :: IO () -> Propellor Result
 makeChange a = liftIO a >> return MadeChange

src/Propellor/Property/Dns.hs

@@ -131,7 +131,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
 otherServers wantedtype hosts domain =
 	M.keys $ M.filter wanted $ hostMap hosts
   where
-	wanted h = case M.lookup domain (_namedconf $ hostAttr h) of
+	wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostAttr h) of
 		Nothing -> False
 		Just conf -> confDnsServerType conf == wantedtype
 			&& confDomain conf == domain
@@ -406,3 +406,10 @@ domainHost base (AbsDomain d)
   where
 	dotbase = '.':base
 
+addNamedConf :: NamedConf -> Attr
+addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) }
+  where
+       domain = confDomain conf
+
+getNamedConf :: Propellor (M.Map Domain NamedConf)
+getNamedConf = asks $ fromNamedConfMap . _namedconf . hostAttr

src/Propellor/Property/Docker.hs

@@ -46,9 +46,9 @@ type ContainerName = String
 -- >    & Apt.installed {"apache2"]
 -- >    & ...
 container :: ContainerName -> Image -> Host
-container cn image = Host hn [] (\_ -> attr)
+container cn image = Host hn [] attr
   where
-	attr = newAttr { _dockerImage = Just image }
+	attr = mempty { _dockerImage = Just image }
 	hn = cn2hn cn
 
 cn2hn :: ContainerName -> HostName
@@ -97,9 +97,7 @@ docked hosts cn = RevertableProperty
 
 exposeDnsAttrs :: Host -> Property -> Property
 exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $
-	p : map addDNS (S.toList containerdns)
+	p : map addDNS (S.toList $ _dns containerattr)
-  where
-	containerdns = _dns $ containerattr newAttr
 
 findContainer
 	:: Maybe Host
@@ -422,14 +420,14 @@ listImages :: IO [Image]
 listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
 runProp :: String -> RunParam -> Property
-runProp field val = pureAttrProperty (param) $ \attr ->
+runProp field val = pureAttrProperty (param) $
-	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
+	mempty { _dockerRunParams = [\_ -> "--"++param] }
   where
 	param = field++"="++val
 
 genProp :: String -> (HostName -> RunParam) -> Property
-genProp field mkval = pureAttrProperty field $ \attr ->
+genProp field mkval = pureAttrProperty field $
-	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
+	mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }
 
 -- | The ContainerIdent of a container is written to
 -- /.propellor-ident inside it. This can be checked to see if

src/Propellor/Types.hs

@@ -4,14 +4,13 @@
 module Propellor.Types
 	( Host(..)
 	, Attr
-	, SetAttr
+	, getAttr
 	, Propellor(..)
 	, Property(..)
 	, RevertableProperty(..)
 	, IsProp
 	, describe
 	, toProp
-	, setAttr
 	, requires
 	, Desc
 	, Result(..)
@@ -39,7 +38,7 @@ import Propellor.Types.Dns
 data Host = Host
 	{ _hostName :: HostName
 	, _hostProps :: [Property]
-	, _hostAttrs :: SetAttr
+	, _hostAttr :: Attr
 	}
 
 -- | Propellor's monad provides read-only access to the host it's running
@@ -61,8 +60,8 @@ data Property = Property
 	{ propertyDesc :: Desc
 	, propertySatisfy :: Propellor Result
 	-- ^ must be idempotent; may run repeatedly
-	, propertyAttr :: SetAttr
+	, propertyAttr :: Attr
-	-- ^ a property can set an Attr on the host that has the property.
+	-- ^ a property can set an attribute of the host that has the property.
 	}
 
 -- | A property that can be reverted.
@@ -75,15 +74,15 @@ class IsProp p where
 	-- | Indicates that the first property can only be satisfied
 	-- once the second one is.
 	requires :: p -> Property -> p
-	setAttr :: p -> SetAttr
+	getAttr :: p -> Attr
 
 instance IsProp Property where
 	describe p d = p { propertyDesc = d }
 	toProp p = p
-	setAttr = propertyAttr
+	getAttr = propertyAttr
 	x `requires` y = Property (propertyDesc x) satisfy attr
 	  where
-	  	attr = propertyAttr x . propertyAttr y
+	  	attr = getAttr y <> getAttr x
 		satisfy = do
 			r <- propertySatisfy y
 			case r of
@@ -98,8 +97,8 @@ instance IsProp RevertableProperty where
 	toProp (RevertableProperty p1 _) = p1
 	(RevertableProperty p1 p2) `requires` y =
 		RevertableProperty (p1 `requires` y) p2
-	-- | Return the SetAttr of the currently active side.
+	-- | Return the Attr of the currently active side.
-	setAttr (RevertableProperty p1 _p2) = setAttr p1
+	getAttr (RevertableProperty p1 _p2) = getAttr p1
 
 type Desc = String
 

src/Propellor/Types/Attr.hs

@@ -4,14 +4,14 @@ import Propellor.Types.OS
 import qualified Propellor.Types.Dns as Dns
 
 import qualified Data.Set as S
-import qualified Data.Map as M
+import Data.Monoid
 
 -- | The attributes of a host.
 data Attr = Attr
 	{ _os :: Maybe System
 	, _sshPubKey :: Maybe String
 	, _dns :: S.Set Dns.Record
-	, _namedconf :: M.Map Dns.Domain Dns.NamedConf
+	, _namedconf :: Dns.NamedConfMap
 
 	, _dockerImage :: Maybe String
 	, _dockerRunParams :: [HostName -> String]
@@ -29,6 +29,23 @@ instance Eq Attr where
 		  in simpl x == simpl y
 		]
 
+instance Monoid Attr where
+	mempty = Attr Nothing Nothing mempty mempty Nothing mempty
+	mappend old new = Attr
+		{ _os = case _os new of
+			Just v -> Just v
+			Nothing -> _os old
+		, _sshPubKey = case _sshPubKey new of
+			Just v -> Just v
+			Nothing -> _sshPubKey old
+		, _dns = _dns new <> _dns old
+		, _namedconf = _namedconf new <> _namedconf old
+		, _dockerImage = case _dockerImage new of
+			Just v -> Just v
+			Nothing -> _dockerImage old
+		, _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
+		}
+
 instance Show Attr where
 	show a = unlines
 		[ "OS " ++ show (_os a)
@@ -38,8 +55,3 @@ instance Show Attr where
 		, "docker image " ++ show (_dockerImage a)
 		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
 		]
-
-newAttr :: Attr
-newAttr = Attr Nothing Nothing S.empty M.empty Nothing []
-
-type SetAttr = Attr -> Attr

src/Propellor/Types/Dns.hs

@@ -3,6 +3,8 @@ module Propellor.Types.Dns where
 import Propellor.Types.OS (HostName)
 
 import Data.Word
+import Data.Monoid
+import qualified Data.Map as M
 
 type Domain = String
 
@@ -90,3 +92,21 @@ domainHostName :: BindDomain -> Maybe HostName
 domainHostName (RelDomain d) = Just d
 domainHostName (AbsDomain d) = Just d
 domainHostName RootDomain = Nothing
+
+newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
+	deriving (Eq, Ord, Show)
+
+-- | Adding a Master NamedConf stanza for a particulr domain always
+-- overrides an existing Secondary stanza for that domain, while a
+-- Secondary stanza is only added when there is no existing Master stanza.
+instance Monoid NamedConfMap where
+	mempty = NamedConfMap M.empty
+	mappend (NamedConfMap old) (NamedConfMap new) = NamedConfMap $
+		M.unionWith combiner new old
+	  where
+		combiner n o = case (confDnsServerType n, confDnsServerType o) of
+			(Secondary, Master) -> o
+			_  -> n
+
+fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf
+fromNamedConfMap (NamedConfMap m) = m