Merge branch 'joeyconfig'

14 files changed, 206 insertions, 155 deletions

diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs
index 98cfc64d..29d7a01e 100644
--- a/src/Propellor/Attr.hs
+++ b/src/Propellor/Attr.hs
@@ -9,86 +9,59 @@ 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)
 
-hostname :: HostName -> Property
-hostname name = pureAttrProperty ("hostname " ++ name) $
-	\d -> d { _hostname = name }
-
-getHostName :: Propellor HostName
-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
+getOS = asks (_os . hostAttr)
 
 -- | Indidate that a host has an A record in the DNS.
 --
 -- TODO check at run time if the host really has this address.
 -- (Can't change the host's address, but as a sanity check.)
 ipv4 :: String -> Property
-ipv4 addr = pureAttrProperty ("ipv4 " ++ addr)
-	(addDNS $ Address $ IPv4 addr)
+ipv4 = addDNS . Address . IPv4
 
 -- | Indidate that a host has an AAAA record in the DNS.
 ipv6 :: String -> Property
-ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)
-	(addDNS $ Address $ IPv6 addr)
+ipv6 = addDNS . Address . IPv6
 
 -- | Indicates another name for the host in the DNS.
 alias :: Domain -> Property
-alias domain = pureAttrProperty ("alias " ++ domain)
-	(addDNS $ CNAME $ AbsDomain domain)
-
-addDNS :: Record -> SetAttr
-addDNS record d = d { _dns = S.insert record (_dns d) }
+alias = addDNS . CNAME . AbsDomain
 
--- | 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 }
+addDNS :: Record -> Property
+addDNS r = pureAttrProperty (rdesc r) $
+	mempty { _dns = S.singleton r }
   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
+	rdesc (CNAME d) = unwords ["alias", ddesc d]
+	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
+	rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr]
+	rdesc (MX n d) = unwords ["MX", show n, ddesc d]
+	rdesc (NS d) = unwords ["NS", ddesc d]
+	rdesc (TXT s) = unwords ["TXT", s]
+	rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]
 
-getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks _namedconf
+	ddesc (AbsDomain domain) = domain
+	ddesc (RelDomain domain) = domain
+	ddesc RootDomain = "@"
 
 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
-
-hostnameless :: Attr
-hostnameless = newAttr (error "hostname Attr not specified")
-
-hostAttr :: Host -> Attr
-hostAttr (Host _ mkattrs) = mkattrs hostnameless
-
-hostProperties :: Host -> [Property]
-hostProperties (Host ps _) = ps
+getSshPubKey = asks (_sshPubKey . hostAttr)
 
 hostMap :: [Host] -> M.Map HostName Host
-hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l 
-
-hostAttrMap :: [Host] -> M.Map HostName Attr
-hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs
-  where
-	attrs = map hostAttr l
+hostMap l = M.fromList $ zip (map hostName l) l 
 
 findHost :: [Host] -> HostName -> Maybe Host
 findHost l hn = M.lookup hn (hostMap l)
@@ -100,12 +73,3 @@ hostAddresses :: HostName -> [Host] -> [IPAddr]
 hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of
 	Nothing -> []
 	Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr
-
--- | Lifts an action into a different host.
---
--- For example, `fromHost hosts "otherhost" getSshPubKey`
-fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
-fromHost l hn getter = case findHost l hn of
-	Nothing -> return Nothing
-	Just h -> liftIO $ Just <$>
-		runReaderT (runWithAttr getter) (hostAttr h)
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index ab1d7f9e..a7b7ef96 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -67,24 +67,21 @@ defaultMain hostlist = do
 	go _ (Continue cmdline) = go False cmdline
 	go _ (Set hn field) = setPrivData hn field
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain hn) = withprops hn $ \attr ps -> do
-		r <- runPropellor attr $ ensureProperties ps
+	go _ (Chain hn) = withhost hn $ \h -> do
+		r <- runPropellor h $ ensureProperties $ hostProperties h
 		putStrLn $ "\n" ++ show r
 	go _ (Docker hn) = Docker.chain hn
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
-	go False (Spin hn) = withprops hn $ const . const $ spin hn
+	go False (Spin hn) = withhost hn $ const $ spin hn
 	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withprops hn mainProperties
+		( onlyProcess $ withhost hn mainProperties
 		, go True (Spin hn)
 		)
-	go False (Boot hn) = onlyProcess $ withprops hn boot
+	go False (Boot hn) = onlyProcess $ withhost hn boot
 
-	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
-	withprops hn a = maybe
-		(unknownhost hn)
-		(\h -> a (hostAttr h) (hostProperties h))
-		(findHost hostlist hn)
+	withhost :: HostName -> (Host -> IO ()) -> IO ()
+	withhost hn a = maybe (unknownhost hn) a (findHost hostlist hn)
 
 onlyProcess :: IO a -> IO a
 onlyProcess a = bracket lock unlock (const a)
@@ -279,15 +276,15 @@ fromMarked marker s
 	len = length marker
 	matches = filter (marker `isPrefixOf`) $ lines s
 
-boot :: Attr -> [Property] -> IO ()
-boot attr ps = do
+boot :: Host -> IO ()
+boot h = do
 	sendMarked stdout statusMarker $ show Ready
 	reply <- hGetContentsStrict stdin
 
 	makePrivDataDir
 	maybe noop (writeFileProtected privDataLocal) $
 		fromMarked privDataMarker reply
-	mainProperties attr ps
+	mainProperties h
 
 addKey :: String -> IO ()
 addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ]
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 55ce7f77..ca0f7265 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -5,20 +5,22 @@ module Propellor.Engine where
 import System.Exit
 import System.IO
 import Data.Monoid
+import Control.Applicative
 import System.Console.ANSI
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Propellor.Message
 import Propellor.Exception
+import Propellor.Attr
 
-runPropellor :: Attr -> Propellor a -> IO a
-runPropellor attr a = runReaderT (runWithAttr a) attr
+runPropellor :: Host -> Propellor a -> IO a
+runPropellor host a = runReaderT (runWithHost a) host
 
-mainProperties :: Attr -> [Property] -> IO ()
-mainProperties attr ps = do
-	r <- runPropellor attr $
-		ensureProperties [Property "overall" (ensureProperties ps) id]
+mainProperties :: Host -> IO ()
+mainProperties host = do
+	r <- runPropellor host $
+		ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
 	setTitle "propellor: done"
 	hFlush stdout
 	case r of
@@ -30,8 +32,18 @@ ensureProperties ps = ensure ps NoChange
   where
 	ensure [] rs = return rs
 	ensure (l:ls) rs = do
-		r <- actionMessage (propertyDesc l) (ensureProperty l)
+		hn <- asks hostName
+		r <- actionMessageOn hn (propertyDesc l) (ensureProperty l)
 		ensure ls (r <> rs)
 
 ensureProperty :: Property -> Propellor Result
 ensureProperty = catchPropellor . propertySatisfy
+
+-- | Lifts an action into a different host.
+--
+-- For example, `fromHost hosts "otherhost" getSshPubKey`
+fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
+fromHost l hn getter = case findHost l hn of
+	Nothing -> return Nothing
+	Just h -> liftIO $ Just <$>
+		runReaderT (runWithHost getter) h
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 780471c3..afbed1ca 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -12,7 +12,15 @@ import Propellor.Types
 -- | Shows a message while performing an action, with a colored status
 -- display.
 actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
-actionMessage desc a = do
+actionMessage = actionMessage' Nothing
+
+-- | Shows a message while performing an action on a specified host,
+-- with a colored status display.
+actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r
+actionMessageOn = actionMessage' . Just
+
+actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
+actionMessage' mhn desc a = do
 	liftIO $ do
 		setTitle $ "propellor: " ++ desc
 		hFlush stdout
@@ -21,12 +29,19 @@ actionMessage desc a = do
 
 	liftIO $ do
 		setTitle "propellor: running"
-		let (msg, intensity, color) = getActionResult r
+		showhn mhn
 		putStr $ desc ++ " ... "
+		let (msg, intensity, color) = getActionResult r
 		colorLine intensity color msg
 		hFlush stdout
 
 	return r
+  where
+	showhn Nothing = return ()
+	showhn (Just hn) = do
+		setSGR [SetColor Foreground Dull Cyan]
+		putStr (hn ++ " ")
+		setSGR []
 
 warningMessage :: MonadIO m => String -> m ()
 warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index ad2c8d22..54f67d73 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -13,7 +13,6 @@ import Control.Monad
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
-import Propellor.Attr
 import Propellor.Message
 import Utility.Monad
 import Utility.PartialPrelude
@@ -30,7 +29,7 @@ withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Resul
 withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
   where
 	missing = do
-		host <- getHostName
+		host <- asks hostName
 		let host' = if ".docker" `isSuffixOf` host
 			then "$parent_host"
 			else host
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 0728932e..e3d46eae 100644
--- a/src/Propellor/Property.hs
+++ b/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 [] (\_ -> newAttr hn)
+host hn = Host hn [] mempty
 
 -- | Adds a property to a Host
 --
 -- Can add Properties and RevertableProperties
 (&) :: IsProp p => Host -> p -> Host
-(Host ps as) & p = Host (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 ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as)
-  where
-	q = revert p
+h ! p = h & 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.
-combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr
-combineSetAttr p q = setAttr p . setAttr q
+-- Combines the Attr of two properties.
+combineAttr :: (IsProp p, IsProp q) => p -> q -> Attr
+combineAttr p q = getAttr p <> getAttr q
 
-combineSetAttrs :: IsProp p => [p] -> SetAttr
-combineSetAttrs = foldl' (.) id . map setAttr
+combineAttrs :: IsProp p => [p] -> Attr
+combineAttrs = mconcat . map getAttr
 
 makeChange :: IO () -> Propellor Result
 makeChange a = liftIO a >> return MadeChange
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 5c3162cb..3e5c7828 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -129,9 +129,9 @@ secondaryFor masters hosts domain = RevertableProperty setup cleanup
 
 otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
 otherServers wantedtype hosts domain =
-	M.keys $ M.filter wanted $ hostAttrMap hosts
+	M.keys $ M.filter wanted $ hostMap hosts
   where
-	wanted attr = case M.lookup domain (_namedconf attr) of
+	wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostAttr h) of
 		Nothing -> False
 		Just conf -> confDnsServerType conf == wantedtype
 			&& confDomain conf == domain
@@ -341,7 +341,7 @@ genZone hosts zdomain soa =
 		]
 	in (Zone zdomain soa (nub zhosts), warnings)
   where
-	m = hostAttrMap hosts
+	m = hostMap hosts
 	-- Known hosts with hostname located in the zone's domain.
 	inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m
 	
@@ -350,12 +350,13 @@ genZone hosts zdomain soa =
 	--
 	-- If a host lacks any IPAddr, it's probably a misconfiguration,
 	-- so warn.
-	hostips :: Attr -> [Either WarningMessage (BindDomain, Record)]
-	hostips attr
-		| null l = [Left $ "no IP address defined for host " ++ _hostname attr]
+	hostips :: Host -> [Either WarningMessage (BindDomain, Record)]
+	hostips h
+		| null l = [Left $ "no IP address defined for host " ++ hostName h]
 		| otherwise = map Right l
 	  where
-		l = zip (repeat $ AbsDomain $ _hostname attr)
+		attr = hostAttr h
+		l = zip (repeat $ AbsDomain $ hostName h)
 			(map Address $ getAddresses attr)
 
 	-- Any host, whether its hostname is in the zdomain or not,
@@ -370,10 +371,11 @@ genZone hosts zdomain soa =
 	--
 	-- We typically know the host's IPAddrs anyway.
 	-- So we can just use the IPAddrs.
-	addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)]
-	addcnames attr = concatMap gen $ filter (inDomain zdomain) $
+	addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
+	addcnames h = concatMap gen $ filter (inDomain zdomain) $
 		mapMaybe getCNAME $ S.toList (_dns attr)
 	  where
+		attr = hostAttr h
 		gen c = case getAddresses attr of
 			[] -> [ret (CNAME c)]
 			l -> map (ret . Address) l
@@ -381,10 +383,11 @@ genZone hosts zdomain soa =
 		  	ret record = Right (c, record)
 	
 	-- Adds any other DNS records for a host located in the zdomain.
-	hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)]
-	hostrecords attr = map Right l
+	hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)]
+	hostrecords h = map Right l
 	  where
-		l = zip (repeat $ AbsDomain $ _hostname attr)
+		attr = hostAttr h
+		l = zip (repeat $ AbsDomain $ hostName h)
 			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))
 
 inDomain :: Domain -> BindDomain -> Bool
@@ -403,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
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 68fbced5..8e081ae4 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -21,6 +21,7 @@ import System.Posix.Directory
 import System.Posix.Process
 import Data.List
 import Data.List.Utils
+import qualified Data.Set as S
 
 -- | Configures docker with an authentication file, so that images can be
 -- pushed to index.docker.io.
@@ -45,16 +46,20 @@ type ContainerName = String
 -- >    & Apt.installed {"apache2"]
 -- >    & ...
 container :: ContainerName -> Image -> Host
-container cn image = Host [] (\_ -> attr)
+container cn image = Host hn [] attr
   where
-	attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
+	attr = mempty { _dockerImage = Just image }
+	hn = cn2hn cn
 
 cn2hn :: ContainerName -> HostName
 cn2hn cn = cn ++ ".docker"
 
 -- | Ensures that a docker container is set up and running. The container
 -- has its own Properties which are handled by running propellor
--- inside the container.
+-- inside the container. 
+--
+-- Additionally, the container can have DNS attributes, such as a CNAME.
+-- These become attributes of the host(s) it's docked in.
 --
 -- Reverting this property ensures that the container is stopped and
 -- removed.
@@ -62,12 +67,16 @@ docked
 	:: [Host]
 	-> ContainerName
 	-> RevertableProperty
-docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
+docked hosts cn = RevertableProperty
+	((maybe id exposeDnsAttrs mhost) (go "docked" setup))
+	(go "undocked" teardown)
   where
 	go desc a = property (desc ++ " " ++ cn) $ do
-		hn <- getHostName
+		hn <- asks hostName
   		let cid = ContainerId hn cn
-		ensureProperties [findContainer hosts cid cn $ a cid]
+		ensureProperties [findContainer mhost cid cn $ a cid]
+		
+	mhost = findHost hosts (cn2hn cn)
 
 	setup cid (Container image runparams) =
 		provisionContainer cid
@@ -86,13 +95,17 @@ docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown
 					]
 			]
 
+exposeDnsAttrs :: Host -> Property -> Property
+exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $
+	p : map addDNS (S.toList $ _dns containerattr)
+
 findContainer
-	:: [Host]
+	:: Maybe Host
 	-> ContainerId
 	-> ContainerName
 	-> (Container -> Property)
 	-> Property
-findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
+findContainer mhost cid cn mk = case mhost of
 	Nothing -> cantfind
 	Just h -> maybe cantfind mk (mkContainer cid h)
   where
@@ -407,14 +420,14 @@ listImages :: IO [Image]
 listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
 runProp :: String -> RunParam -> Property
-runProp field val = pureAttrProperty (param) $ \attr ->
-	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
+runProp field val = pureAttrProperty (param) $
+	mempty { _dockerRunParams = [\_ -> "--"++param] }
   where
 	param = field++"="++val
 
 genProp :: String -> (HostName -> RunParam) -> Property
-genProp field mkval = pureAttrProperty field $ \attr ->
-	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
+genProp field mkval = pureAttrProperty field $
+	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
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 3859649e..3a6283cf 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.File as File
 -- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is
 -- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).
 sane :: Property
-sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName)
+sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
 
 setTo :: HostName -> Property
 setTo hn = combineProperties desc go
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 9fa4a2c3..ef96e086 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -16,7 +16,7 @@ satellite :: Property
 satellite = setup `requires` installed
   where
 	setup = trivial $ property "postfix satellite system" $ do
-		hn <- getHostName
+		hn <- asks hostName
 		ensureProperty $ Apt.reConfigure "postfix"
 			[ ("postfix/main_mailer_type", "select", "Satellite system")
 			, ("postfix/root_address", "string", "root")
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 587e16af..f6e1e37f 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -317,3 +317,16 @@ ircBouncer = propertyList "IRC bouncer"
 	]
   where
 	conf = "/home/znc/.znc/configs/znc.conf"
+
+kiteShellBox :: Property
+kiteShellBox = propertyList "kitenet.net shellinabox"
+	[ Apt.installed ["shellinabox"]
+	, File.hasContent "/etc/default/shellinabox"
+		[ "# Deployed by propellor"
+		, "SHELLINABOX_DAEMON_START=1"
+		, "SHELLINABOX_PORT=443"
+		, "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\""
+		]
+		`onChange` Service.restarted "shellinabox"
+	, Service.running "shellinabox"
+	]
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 8a4bd3dd..4ea97bce 100644
--- a/src/Propellor/Types.hs
+++ b/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(..)
@@ -34,18 +33,22 @@ import Propellor.Types.Attr
 import Propellor.Types.OS
 import Propellor.Types.Dns
 
--- | Everything Propellor knows about a system: Its properties and
--- attributes.
-data Host = Host [Property] SetAttr
+-- | Everything Propellor knows about a system: Its hostname,
+-- properties and attributes.
+data Host = Host
+	{ hostName :: HostName
+	, hostProperties :: [Property]
+	, hostAttr :: Attr
+	}
 
--- | Propellor's monad provides read-only access to attributes of the
--- system.
-newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
+-- | Propellor's monad provides read-only access to the host it's running
+-- on, including its attributes.
+newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p }
 	deriving
 		( Monad
 		, Functor
 		, Applicative
-		, MonadReader Attr 
+		, MonadReader Host
 		, MonadIO
 		, MonadCatchIO
 		)
@@ -57,8 +60,8 @@ data Property = Property
 	{ propertyDesc :: Desc
 	, propertySatisfy :: Propellor Result
 	-- ^ must be idempotent; may run repeatedly
-	, propertyAttr :: SetAttr
-	-- ^ a property can set an Attr on the host that has the property.
+	, propertyAttr :: Attr
+	-- ^ a property can set an attribute of the host that has the property.
 	}
 
 -- | A property that can be reverted.
@@ -71,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
@@ -94,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.
-	setAttr (RevertableProperty p1 _p2) = setAttr p1
+	-- | Return the Attr of the currently active side.
+	getAttr (RevertableProperty p1 _p2) = getAttr p1
 
 type Desc = String
 
diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs
index 8b7d3b09..4c891a46 100644
--- a/src/Propellor/Types/Attr.hs
+++ b/src/Propellor/Types/Attr.hs
@@ -4,15 +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. For example, its hostname.
+-- | The attributes of a host.
 data Attr = Attr
-	{ _hostname :: HostName
-	, _os :: Maybe System
+	{ _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]
@@ -20,8 +19,7 @@ data Attr = Attr
 
 instance Eq Attr where
 	x == y = and
-		[ _hostname x == _hostname y
-		, _os x == _os y
+		[ _os x == _os y
 		, _dns x == _dns y
 		, _namedconf x == _namedconf y
 		, _sshPubKey x == _sshPubKey y
@@ -31,18 +29,29 @@ 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
-		[ "hostname " ++ _hostname a
-		, "OS " ++ show (_os a)
+		[ "OS " ++ show (_os a)
 		, "sshPubKey " ++ show (_sshPubKey a)
 		, "dns " ++ show (_dns a)
 		, "namedconf " ++ show (_namedconf a)
 		, "docker image " ++ show (_dockerImage a)
 		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
 		]
-
-newAttr :: HostName -> Attr
-newAttr hn = Attr hn Nothing Nothing S.empty M.empty Nothing []
-
-type SetAttr = Attr -> Attr
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index ba6a92dd..66fbd1a4 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/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