Merge branch 'joeyconfig'

config-joey.hs

@@ -41,7 +41,7 @@ hosts =                 --                  (o)  `
 		& Apt.buildDep ["git-annex"] `period` Daily
 		& Docker.docked hosts "android-git-annex"
 
-	-- Nothing super-important lives here.
+	-- Nothing super-important lives here and mostly it's docker containers.
 	, standardSystem "clam.kitenet.net" Unstable "amd64"
 		& ipv4 "162.248.143.249"
 		& ipv6 "2002:5044:5531::1"
@@ -53,14 +53,9 @@ hosts =                 --                  (o)  `
 		& Postfix.satellite
 		& Docker.configured
 
-		& alias "shell.olduse.net"
+		& Docker.docked hosts "oldusenet-shellbox"
-		& JoeySites.oldUseNetShellBox
-
-		& alias "openid.kitenet.net"
 		& Docker.docked hosts "openid-provider"
 		 	`requires` Apt.serviceInstalledRunning "ntp"
-
-		& alias "ancient.kitenet.net"
 		& Docker.docked hosts "ancient-kitenet"
 
 		-- I'd rather this were on diatom, but it needs unstable.
@@ -76,9 +71,15 @@ hosts =                 --                  (o)  `
 		& alias "znc.kitenet.net"
 		& JoeySites.ircBouncer
 
-		-- Nothing is using https on clam, so listen on that port
+		-- For https port 443, shellinabox with ssh login to
-		-- for ssh, for traveling on bad networks.
+		-- kitenet.net
-		& "/etc/ssh/sshd_config" `File.containsLine` "Port 443"
+		& alias "shell.kitenet.net"
+		& JoeySites.kiteShellBox
+
+		-- Nothing is using http port 80 on clam, so listen on
+		-- that port for ssh, for traveling on bad networks that
+		-- block 22.
+		& "/etc/ssh/sshd_config" `File.containsLine` "Port 80"
 			`onChange` Service.restarted "ssh"
 
 		& Docker.garbageCollected `period` Daily
@@ -179,17 +180,24 @@ hosts =                 --                  (o)  `
 	-- My own openid provider. Uses php, so containerized for security
 	-- and administrative sanity.
 	, standardContainer "openid-provider" Stable "amd64"
+		& alias "openid.kitenet.net"
 		& Docker.publish "8081:80"
 		& OpenId.providerFor ["joey", "liw"]
 			"openid.kitenet.net:8081"
 
 	-- Exhibit: kite's 90's website.
 	, standardContainer "ancient-kitenet" Stable "amd64"
+		& alias "ancient.kitenet.net"
 		& Docker.publish "1994:80"
 		& Apt.serviceInstalledRunning "apache2"
 		& Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www"
 			(Just "remotes/origin/old-kitenet.net")
 	
+	, standardContainer "oldusenet-shellbox" Stable "amd64"
+		& alias "shell.olduse.net"
+		& Docker.publish "4200:4200"
+		& JoeySites.oldUseNetShellBox
+
 	-- git-annex autobuilder containers
 	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h"
 	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h"
@@ -307,7 +315,6 @@ monsters =	      -- but do want to track their public keys etc.
 		& alias "www.wortroot.kitenet.net"
 		& alias "joey.kitenet.net"
 		& alias "anna.kitenet.net"
-		& alias "ipv6.kitenet.net"
 		& alias "bitlbee.kitenet.net"
 		{- Remaining services on kite:
 		 - 
@@ -329,11 +336,10 @@ monsters =	      -- but do want to track their public keys etc.
 		 -   (branchable is still pushing to here
 		 -    (thinking it's ns2.branchable.com), but it's no
 		 -   longer a primary or secondary for anything)
-		 - ajaxterm
 		 - ftpd (EOL)
 		 -
 		 - user shell stuff:
-		 -   pine, zsh, make, ...
+		 -   pine, zsh, make, git-annex, myrepos, ...
 		 -}
 	, host "mouse.kitenet.net"
 		& ipv6 "2001:4830:1600:492::2"

debian/changelog

@@ -1,3 +1,14 @@
+propellor (0.6.0) UNRELEASED; urgency=medium
+
+  * Docker containers now propigate DNS attributes out to the host they're
+    docked in. So if a docker container sets a DNS alias, every container
+    it's docked in will automatically become part of a round-robin DNS,
+    if propellor is used to manage DNS for the domain.
+  * Propellor's output now includes the hostname being provisioned, or
+    when provisioning a docker container, the container name.
+
+ -- Joey Hess <joeyh@debian.org>  Sat, 31 May 2014 16:41:56 -0400
+
 propellor (0.5.3) unstable; urgency=medium
 
   * Fix unattended-upgrades config for !stable.

doc/todo/docker_todo_list.mdwn

@@ -1,8 +1,3 @@
-* Display of docker container properties is a bit wonky. It always
-  says they are unchanged even when they changed and triggered a
-  reprovision.
 * There is no way for a property of a docker container to require
   some property be met outside the container. For example, some servers
   need ntp installed for a good date source.
-* Docking a container in a host should add to the host any cnames that
-  are assigned to the container.

propellor.cabal

@@ -1,5 +1,5 @@
 Name: propellor
-Version: 0.5.3
+Version: 0.6.0
 Cabal-Version: >= 1.6
 License: BSD3
 Maintainer: Joey Hess <joey@kitenet.net>
@@ -35,7 +35,7 @@ Description:
 
 Executable wrapper
   Main-Is: wrapper.hs
-  GHC-Options: -Wall -threaded
+  GHC-Options: -Wall -threaded -O0
   Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
@@ -47,7 +47,7 @@ Executable wrapper
 
 Executable config
   Main-Is: config.hs
-  GHC-Options: -Wall -threaded
+  GHC-Options: -Wall -threaded -0O
   Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
@@ -58,7 +58,7 @@ Executable config
     Build-Depends: unix
 
 Library
-  GHC-Options: -Wall
+  GHC-Options: -Wall -O0
   Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,

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)
+ipv4 = addDNS . Address . IPv4
-	(addDNS $ Address $ IPv4 addr)
 
 -- | Indidate that a host has an AAAA record in the DNS.
 ipv6 :: String -> Property
-ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)
+ipv6 = addDNS . Address . IPv6
-	(addDNS $ Address $ IPv6 addr)
 
 -- | Indicates another name for the host in the DNS.
 alias :: Domain -> Property
-alias domain = pureAttrProperty ("alias " ++ domain)
+alias = addDNS . CNAME . AbsDomain
-	(addDNS $ CNAME $ AbsDomain domain)
 
-addDNS :: Record -> SetAttr
+addDNS :: Record -> Property
-addDNS record d = d { _dns = S.insert record (_dns d) }
+addDNS r = pureAttrProperty (rdesc r) $
-
+	mempty { _dns = S.singleton r }
--- | 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
+	rdesc (CNAME d) = unwords ["alias", ddesc d]
-	domain = confDomain conf
+	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
-	new = case (confDnsServerType conf, confDnsServerType <$> M.lookup domain m) of
+	rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr]
-		(Secondary, Just Master) -> m
+	rdesc (MX n d) = unwords ["MX", show n, ddesc d]
-		_  -> M.insert domain conf m
+	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)
+	ddesc (AbsDomain domain) = domain
-getNamedConf = asks _namedconf
+	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
+getSshPubKey = asks (_sshPubKey . hostAttr)
-
-hostnameless :: Attr
-hostnameless = newAttr (error "hostname Attr not specified")
-
-hostAttr :: Host -> Attr
-hostAttr (Host _ mkattrs) = mkattrs hostnameless
-
-hostProperties :: Host -> [Property]
-hostProperties (Host ps _) = ps
 
 hostMap :: [Host] -> M.Map HostName Host
-hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l 
+hostMap l = M.fromList $ zip (map hostName l) l 
-
-hostAttrMap :: [Host] -> M.Map HostName Attr
-hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs
-  where
-	attrs = map hostAttr 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)

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
+	go _ (Chain hn) = withhost hn $ \h -> do
-		r <- runPropellor attr $ ensureProperties ps
+		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 ()
+	withhost :: HostName -> (Host -> IO ()) -> IO ()
-	withprops hn a = maybe
+	withhost hn a = maybe (unknownhost hn) a (findHost hostlist hn)
-		(unknownhost hn)
-		(\h -> a (hostAttr h) (hostProperties h))
-		(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 :: Host -> IO ()
-boot attr ps = do
+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 ]

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 :: Host -> Propellor a -> IO a
-runPropellor attr a = runReaderT (runWithAttr a) attr
+runPropellor host a = runReaderT (runWithHost a) host
 
-mainProperties :: Attr -> [Property] -> IO ()
+mainProperties :: Host -> IO ()
-mainProperties attr ps = do
+mainProperties host = do
-	r <- runPropellor attr $
+	r <- runPropellor host $
-		ensureProperties [Property "overall" (ensureProperties ps) id]
+		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

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

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

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

@@ -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 :: Host -> [Either WarningMessage (BindDomain, Record)]
-	hostips attr
+	hostips h
-		| null l = [Left $ "no IP address defined for host " ++ _hostname attr]
+		| 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 :: Host -> [Either WarningMessage (BindDomain, Record)]
-	addcnames attr = concatMap gen $ filter (inDomain zdomain) $
+	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 :: Host -> [Either WarningMessage (BindDomain, Record)]
-	hostrecords attr = map Right l
+	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

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,9 +46,10 @@ 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"
@@ -56,18 +58,25 @@ cn2hn cn = cn ++ ".docker"
 -- has its own Properties which are handled by running propellor
 -- 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.
 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 ->
+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/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

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

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

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
+-- | Everything Propellor knows about a system: Its hostname,
--- attributes.
+-- properties and attributes.
-data Host = Host [Property] SetAttr
+data Host = Host
+	{ hostName :: HostName
+	, hostProperties :: [Property]
+	, hostAttr :: Attr
+	}
 
--- | Propellor's monad provides read-only access to attributes of the
+-- | Propellor's monad provides read-only access to the host it's running
--- system.
+-- on, including its attributes.
-newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
+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
+	, 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.
@@ -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.
+	-- | 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,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

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