propellor 0.5.3 → 0.6.0

raw patch · 23 files changed

+500/−218 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +14/−0
• config-joey.hs +81/−16
• config-simple.hs +5/−2
• debian/changelog +14/−0
• propellor.cabal +4/−4
• src/Propellor/Attr.hs +30/−58
• src/Propellor/CmdLine.hs +18/−16
• src/Propellor/Engine.hs +19/−7
• src/Propellor/Message.hs +17/−2
• src/Propellor/PrivData.hs +12/−3
• src/Propellor/Property.hs +12/−16
• src/Propellor/Property/Apt.hs +16/−3
• src/Propellor/Property/Dns.hs +34/−13
• src/Propellor/Property/Docker.hs +91/−26
• src/Propellor/Property/Hostname.hs +1/−1
• src/Propellor/Property/Obnam.hs +5/−1
• src/Propellor/Property/Postfix.hs +1/−1
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +12/−4
• src/Propellor/Property/SiteSpecific/JoeySites.hs +21/−0
• src/Propellor/Types.hs +24/−16
• src/Propellor/Types/Attr.hs +44/−27
• src/Propellor/Types/Dns.hs +20/−0
• src/config.hs +5/−2

@@ -1,3 +1,17 @@+propellor (0.6.0) unstable; urgency=medium++  * Docker containers now propagate 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 be added to a DNS round-robin,+    when propellor is used to manage DNS for the domain.+  * Apt.stdSourcesList no longer needs a suite to be specified.+  * Added --dump to dump out a field of a host's privdata. Useful for editing+    it.+  * Propellor's output now includes the hostname being provisioned, or+    when provisioning a docker container, the container name.++ -- Joey Hess <joeyh@debian.org>  Thu, 05 Jun 2014 17:32:14 -0400+ propellor (0.5.3) unstable; urgency=medium    * Fix unattended-upgrades config for !stable.

@@ -37,11 +37,12 @@ 	-- My laptop 	[ host "darkstar.kitenet.net" 		& ipv6 "2001:4830:1600:187::2" -- sixxs tunnel-		& Docker.configured+ 		& Apt.buildDep ["git-annex"] `period` Daily+		& Docker.configured 		& 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 +54,9 @@ 		& Postfix.satellite 		& Docker.configured -		& alias "shell.olduse.net"-		& JoeySites.oldUseNetShellBox--		& alias "openid.kitenet.net"+		& Docker.docked hosts "oldusenet-shellbox" 		& 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 +72,15 @@ 		& alias "znc.kitenet.net" 		& JoeySites.ircBouncer -		-- Nothing is using https on clam, so listen on that port-		-- for ssh, for traveling on bad networks.-		& "/etc/ssh/sshd_config" `File.containsLine` "Port 443"+		-- For https port 443, shellinabox with ssh login to+		-- kitenet.net+		& 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@@ -161,7 +163,25 @@ 		 		& Dns.secondaryFor ["animx"] hosts "animx.eu.org" +	-- storage and backup server+	, standardSystem "elephant.kitenet.net" Unstable "amd64"+		& ipv4 "193.234.225.114" +		& Hostname.sane+		& Postfix.satellite+		& Apt.unattendedUpgrades++		& alias "eubackup.kitenet.net"+		& Apt.installed ["obnam", "sshfs", "rsync"]+		& JoeySites.githubBackup++		& alias "podcatcher.kitenet.net"+		& Apt.installed ["git-annex"]+		+		& Docker.configured+		! Docker.docked hosts "voltagex"+		& Docker.garbageCollected `period` (Weekly (Just 1))+ 	    --'                        __|II|      ,. 	  ----                      __|II|II|__   (  \_,/\ 	 ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-@@ -179,17 +199,24 @@ 	-- 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"@@ -202,14 +229,25 @@ 	, let gitannexdir = GitAnnexBuilder.homedir </> "git-annex" 	  in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir 		& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)++	-- temp for an acquantance+	, standardContainer "voltagex" Stable "amd64"+		& Docker.publish "22022:22"+		& Docker.memory "500m"+		& Docker.cpuShares 1+		& Apt.serviceInstalledRunning "ssh"+		& Ssh.permitRootLogin True+		& Ssh.passwordAuthentication True+		& User.hasSomePassword "root"+ 	] ++ monsters  -- This is my standard system setup. standardSystem :: HostName -> DebianSuite -> Architecture -> Host standardSystem hn suite arch = host hn 	& os (System (Debian suite) arch)-	& Apt.stdSourcesList suite-		`onChange` Apt.upgrade+	& Apt.stdSourcesList `onChange` Apt.upgrade+	& Apt.cacheCleaned 	& Apt.installed ["etckeeper"] 	& Apt.installed ["ssh"] 	& GitHome.installedFor "root"@@ -231,9 +269,11 @@ -- This is my standard container setup, featuring automatic upgrades. standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host standardContainer name suite arch = Docker.container name (dockerImage system)-	& os (System (Debian suite) arch)-	& Apt.stdSourcesList suite+	& os system+	& Apt.stdSourcesList `onChange` Apt.upgrade+	& Apt.installed ["systemd"] 	& Apt.unattendedUpgrades+	& Apt.cacheCleaned   where 	system = System (Debian suite) arch @@ -306,8 +346,33 @@ 		& alias "wortroot.kitenet.net" 		& alias "www.wortroot.kitenet.net" 		& alias "joey.kitenet.net"-		& alias "ipv6.kitenet.net"+		& alias "anna.kitenet.net" 		& alias "bitlbee.kitenet.net"+		{- Remaining services on kite:+		 - +		 - mail+		 -   postfix+		 -   postgrey+		 -   mailman+		 -   spamassassin+		 -   sqwebmail+		 -   courier+		 -     imap+		 -     tls+		 - apache+		 -   some static websites+		 - bitlbee+		 - prosody+		 -   (used by anna and daddy's git-annex)+		 - named+		 -   (branchable is still pushing to here+		 -    (thinking it's ns2.branchable.com), but it's no+		 -   longer a primary or secondary for anything)+		 - ftpd (EOL)+		 -+		 - user shell stuff:+		 -   pine, zsh, make, git-annex, myrepos, ...+		 -} 	, host "mouse.kitenet.net" 		& ipv6 "2001:4830:1600:492::2" 	, host "beaver.kitenet.net"

@@ -24,7 +24,8 @@ hosts :: [Host] hosts = 	[ host "mybox.example.com"-		& Apt.stdSourcesList Unstable+		& os (System (Debian Unstable) "amd64")+		& Apt.stdSourcesList 		& Apt.unattendedUpgrades 		& Apt.installed ["etckeeper"] 		& Apt.installed ["ssh"]@@ -36,7 +37,9 @@ 		& Cron.runPropellor "30 * * * *"  	-- A generic webserver in a Docker container.-	, Docker.container "webserver" "joeyh/debian-unstable"+	, Docker.container "webserver" "joeyh/debian-stable"+		& os (System (Debian Stable) "amd64")+		& Apt.stdSourcesList 		& Docker.publish "80:80" 		& Docker.volume "/var/www:/var/www" 		& Apt.serviceInstalledRunning "apache2"

@@ -1,3 +1,17 @@+propellor (0.6.0) unstable; urgency=medium++  * Docker containers now propagate 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 be added to a DNS round-robin,+    when propellor is used to manage DNS for the domain.+  * Apt.stdSourcesList no longer needs a suite to be specified.+  * Added --dump to dump out a field of a host's privdata. Useful for editing+    it.+  * Propellor's output now includes the hostname being provisioned, or+    when provisioning a docker container, the container name.++ -- Joey Hess <joeyh@debian.org>  Thu, 05 Jun 2014 17:32:14 -0400+ propellor (0.5.3) unstable; urgency=medium    * Fix unattended-upgrades config for !stable.

@@ -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 @@  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 config   Main-Is: config.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,@@ -58,7 +58,7 @@     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,

@@ -9,86 +9,67 @@ 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+askAttr :: (Attr -> Val a) -> Propellor (Maybe a)+askAttr f = asks (fromVal . f . hostAttr)  os :: System -> Property os system = pureAttrProperty ("Operating " ++ show system) $-	\d -> d { _os = Just system }+	mempty { _os = Val system }  getOS :: Propellor (Maybe System)-getOS = asks _os+getOS = askAttr _os  -- | 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.+--+-- When the host's ipv4/ipv6 addresses are known, the alias is set up+-- 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 = 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 = Val 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 = askAttr _sshPubKey  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 +81,3 @@ 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)

@@ -27,6 +27,7 @@ 		, "  propellor hostname" 		, "  propellor --spin hostname" 		, "  propellor --set hostname field"+		, "  propellor --dump hostname field" 		, "  propellor --add-key keyid" 		] 	exitFailure@@ -38,9 +39,8 @@   	go ("--spin":h:[]) = return $ Spin h   	go ("--boot":h:[]) = return $ Boot h 	go ("--add-key":k:[]) = return $ AddKey k-	go ("--set":h:f:[]) = case readish f of-		Just pf -> return $ Set h pf-		Nothing -> errorMessage $ "Unknown privdata field " ++ f+	go ("--set":h:f:[]) = withprivfield f (return . Set h)+	go ("--dump":h:f:[]) = withprivfield f (return . Dump h) 	go ("--continue":s:[]) = case readish s of 		Just cmdline -> return $ Continue cmdline 		Nothing -> errorMessage "--continue serialization failure"@@ -56,6 +56,10 @@ 			else return $ Run s 	go _ = usage +	withprivfield s f = case readish s of+		Just pf -> f pf+		Nothing -> errorMessage $ "Unknown privdata field " ++ s+ defaultMain :: [Host] -> IO () defaultMain hostlist = do 	DockerShim.cleanEnv@@ -66,25 +70,23 @@   where 	go _ (Continue cmdline) = go False cmdline 	go _ (Set hn field) = setPrivData hn field+	go _ (Dump hn field) = dumpPrivData 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 +281,15 @@ 	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 ]

@@ -5,20 +5,22 @@ 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 @@   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

@@ -12,7 +12,15 @@ -- | 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 @@  	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

@@ -13,7 +13,6 @@ 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 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@@ -50,7 +49,7 @@ 	value <- chomp <$> hGetContentsStrict stdin 	makePrivDataDir 	let f = privDataFile host-	m <- fromMaybe M.empty . readish <$> gpgDecrypt f+	m <- decryptPrivData host 	let m' = M.insert field value m 	gpgEncrypt f (show m') 	putStrLn "Private data set."@@ -59,6 +58,16 @@ 	chomp s 		| end s == "\n" = chomp (beginning s) 		| otherwise = s++dumpPrivData :: HostName -> PrivDataField -> IO ()+dumpPrivData host field = go . M.lookup field =<< decryptPrivData host+  where+	go Nothing = error "Requested privdata is not set."+	go (Just s) = putStrLn s++decryptPrivData :: HostName -> IO (M.Map PrivDataField String)+decryptPrivData host = fromMaybe M.empty . readish+	<$> gpgDecrypt (privDataFile host)  makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir

@@ -5,12 +5,10 @@ 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 @@  -- 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 @@ --- | 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 @@ -- > 	! 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 @@ 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

@@ -64,13 +64,20 @@ 	| otherwise = []  -- | Makes sources.list have a standard content using the mirror CDN,--- with a particular DebianSuite.+-- with the Debian suite configured by the os. -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org.-stdSourcesList :: DebianSuite -> Property-stdSourcesList suite = stdSourcesList' suite []+stdSourcesList :: Property+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 suite = stdSourcesList' suite []+ -- | Adds additional sources.list generators. -- -- Note that if a Property needs to enable an apt source, it's better@@ -254,3 +261,9 @@ 				hPutStr h (pubkey k) 				hClose h 		nukeFile $ f ++ "~" -- gpg dropping++-- | Cleans apt's cache of downloaded packages to avoid using up disk+-- space.+cacheCleaned :: Property+cacheCleaned = cmdProperty "apt-get" ["clean"]+	`describe` "apt cache cleaned" 

@@ -129,9 +129,9 @@  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@@ -339,9 +339,9 @@ 		, map hostrecords inzdomain 		, map addcnames (M.elems m) 		]-	in (Zone zdomain soa (nub zhosts), warnings)+	in (Zone zdomain soa (simplify 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 @@ 	-- 	-- 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 @@ 	-- 	-- 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,12 +383,24 @@ 		  	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)) +	-- Simplifies the list of hosts. Remove duplicate entries.+	-- Also, filter out any CHAMES where the same domain has an+	-- IP address, since that's not legal.+	simplify :: [(BindDomain, Record)] -> [(BindDomain, Record)]+	simplify l = nub $ filter (not . dupcname ) l+	  where+		dupcname (d, CNAME _) | any (matchingaddr d) l = True+		dupcname _ = False+		matchingaddr d (d', (Address _)) | d == d' = True+		matchingaddr _ _ = False+ inDomain :: Domain -> BindDomain -> Bool inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d inDomain _ _ = False -- can't tell, so assume not@@ -403,3 +417,10 @@   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

@@ -5,7 +5,33 @@ -- The existance of a docker container is just another Property of a system, -- which propellor can set up. See config.hs for an example. -module Propellor.Property.Docker where+module Propellor.Property.Docker (+	-- * Host properties+	installed,+	configured,+	container,+	docked,+	memoryLimited,+	garbageCollected,+	Image,+	ContainerName,+	-- * Container configuration+	dns,+	hostname,+	name,+	publish,+	expose,+	user,+	volume,+	volumes_from,+	workdir,+	memory,+	cpuShares,+	link,+	ContainerAlias,+	-- * Internal use+	chain,+) where  import Propellor import Propellor.SimpleSh@@ -16,23 +42,24 @@ import Utility.SafeCommand import Utility.Path -import Control.Concurrent.Async+import Control.Concurrent.Async hiding (link) import System.Posix.Directory import System.Posix.Process import Data.List import Data.List.Utils+import qualified Data.Set as S +installed :: Property+installed = Apt.installed ["docker.io"]+ -- | Configures docker with an authentication file, so that images can be--- pushed to index.docker.io.+-- pushed to index.docker.io. Optional. configured :: Property configured = property "docker configured" go `requires` installed   where 	go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $  		"/root/.dockercfg" `File.hasContent` (lines cfg) -installed :: Property-installed = Apt.installed ["docker.io"]- -- | A short descriptive name for a container. -- Should not contain whitespace or other unusual characters, -- only [a-zA-Z0-9_-] are allowed@@ -45,29 +72,39 @@ -- >    & 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 = dockerAttr $ mempty { _dockerImage = Val 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.+-- | Ensures that a docker container is set up and running, finding+-- its configuration in the passed list of hosts.+-- +-- The container 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 +123,17 @@ 					] 			] +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@@ -103,10 +144,10 @@  mkContainer :: ContainerId -> Host -> Maybe Container mkContainer cid@(ContainerId hn _cn) h = Container-	<$> _dockerImage attr+	<$> fromVal (_dockerImage attr) 	<*> pure (map (\a -> a hn) (_dockerRunParams attr))   where-	attr = hostAttr h'+	attr = _dockerattr $ hostAttr h'   	h' = h 		-- expose propellor directory inside the container 		& volume (localdir++":"++localdir)@@ -131,6 +172,20 @@ 	gcimages = property "docker images garbage collected" $ do 		liftIO $ report <$> (mapM removeImage =<< listImages) +-- | Configures the kernel to respect docker memory limits. +--+-- This assumes the system boots using grub 2. And that you don't need any+-- other GRUB_CMDLINE_LINUX_DEFAULT settings.+--+-- Only takes effect after reboot. (Not automated.)+memoryLimited :: Property+memoryLimited = "/etc/default/grub" `File.containsLine` cfg+	`describe` "docker memory limited" +	`onChange` cmdProperty "update-grub" []+  where+	cmdline = "cgroup_enable=memory swapaccount=1"+	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""+ data Container = Container Image [RunParam]  -- | Parameters to pass to `docker run` when creating a container.@@ -181,10 +236,20 @@ workdir = runProp "workdir"  -- | Memory limit for container.---Format: <number><optional unit>, where unit = b, k, m or g+-- Format: <number><optional unit>, where unit = b, k, m or g+--+-- Note: Only takes effect when the host has the memoryLimited property+-- enabled. memory :: String -> Property 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 = runProp "cpu-shares" . show+ -- | Link with another container on the same host. link :: ContainerName -> ContainerAlias -> Property link linkwith calias = genProp "link" $ \hn ->@@ -205,9 +270,6 @@ data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] 	deriving (Read, Show, Eq) -ident2id :: ContainerIdent -> ContainerId-ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn- toContainerId :: String -> Maybe ContainerId toContainerId s 	| myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of@@ -407,14 +469,17 @@ 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) $ dockerAttr $+	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 $ dockerAttr $+	mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }++dockerAttr :: DockerAttr -> Attr+dockerAttr a = mempty { _dockerattr = a }  -- | The ContainerIdent of a container is written to -- /.propellor-ident inside it. This can be checked to see if

@@ -9,7 +9,7 @@ -- 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

@@ -38,8 +38,12 @@ -- -- How awesome is that? backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property-backup dir crontimes params numclients = cronjob `describe` desc+backup dir crontimes params numclients = backup' dir crontimes params numclients 	`requires` restored dir params++-- | Does a backup, but does not automatically restore.+backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property+backup' dir crontimes params numclients = cronjob `describe` desc   where 	desc = dir ++ " backed up by obnam" 	cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $

@@ -16,7 +16,7 @@ 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")

@@ -99,7 +99,9 @@ standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder") 	(dockerImage $ System (Debian Unstable) arch)-	& Apt.stdSourcesList Unstable+	& os (System (Debian Unstable) arch)+	& Apt.stdSourcesList+	& Apt.installed ["systemd"] 	& Apt.unattendedUpgrades 	& buildDepsApt 	& autobuilder (show buildminute ++ " * * * *") timeout True@@ -115,7 +117,9 @@ androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name 	(dockerImage $ System (Debian Stable) "i386")-	& Apt.stdSourcesList Stable+	& os (System (Debian Stable) "i386")+	& Apt.stdSourcesList+	& Apt.installed ["systemd"] 	& User.accountFor builduser 	& File.dirExists gitbuilderdir 	& File.ownerGroup homedir builduser builduser@@ -140,7 +144,9 @@ armelCompanionContainer :: (System -> Docker.Image) -> Host armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion" 	(dockerImage $ System (Debian Unstable) "amd64")-	& Apt.stdSourcesList Unstable+	& os (System (Debian Unstable) "amd64")+	& Apt.stdSourcesList+	& Apt.installed ["systemd"] 	& Apt.unattendedUpgrades 	-- This volume is shared with the armel builder. 	& Docker.volume gitbuilderdir@@ -156,8 +162,10 @@ armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" 	(dockerImage $ System (Debian Unstable) "armel")-	& Apt.stdSourcesList Unstable+	& os (System (Debian Unstable) "armel")+	& Apt.stdSourcesList 	& Apt.unattendedUpgrades+	& Apt.installed ["systemd"] 	& Apt.installed ["openssh-client"] 	& Docker.link "armel-git-annex-builder-companion" "companion" 	& Docker.volumes_from "armel-git-annex-builder-companion"

@@ -317,3 +317,24 @@ 	]   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"+	]++githubBackup :: Property+githubBackup = propertyList "github-backup box"+	[ Apt.installed ["github-backup", "moreutils"]+	, let f = "/home/joey/.github-keys"+	  in File.hasPrivContent f+		`onChange` File.ownerGroup f "joey" "joey"+	]

@@ -4,14 +4,13 @@ module Propellor.Types 	( Host(..) 	, Attr-	, SetAttr+	, getAttr 	, Propellor(..) 	, Property(..) 	, RevertableProperty(..) 	, IsProp 	, describe 	, toProp-	, setAttr 	, requires 	, Desc 	, Result(..)@@ -34,18 +33,23 @@ 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+	}+	deriving (Show) --- | 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,10 +61,13 @@ 	{ 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. 	} +instance Show Property where+	show p = "property " ++ show (propertyDesc p)+ -- | A property that can be reverted. data RevertableProperty = RevertableProperty Property Property @@ -71,15 +78,15 @@ 	-- | 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 +101,8 @@ 	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 @@ -129,6 +136,7 @@ 	| Spin HostName 	| Boot HostName 	| Set HostName PrivDataField+	| Dump HostName PrivDataField 	| AddKey String 	| Continue CmdLine 	| Chain HostName

@@ -4,45 +4,62 @@ 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-	, _sshPubKey :: Maybe String+	{ _os :: Val System+	, _sshPubKey :: Val String 	, _dns :: S.Set Dns.Record-	, _namedconf :: M.Map Dns.Domain Dns.NamedConf+	, _namedconf :: Dns.NamedConfMap+	, _dockerattr :: DockerAttr+	}+	deriving (Eq, Show) -	, _dockerImage :: Maybe String+instance Monoid Attr where+	mempty = Attr mempty mempty mempty mempty mempty+	mappend old new = Attr+		{ _os = _os old <> _os new+		, _sshPubKey = _sshPubKey old <> _sshPubKey new+		, _dns = _dns old <> _dns new+		, _namedconf = _namedconf old <> _namedconf new+		, _dockerattr = _dockerattr old <> _dockerattr new+		}++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++fromVal :: Val a -> Maybe a+fromVal (Val a) = Just a+fromVal NoVal = Nothing++data DockerAttr = DockerAttr+	{ _dockerImage :: Val String 	, _dockerRunParams :: [HostName -> String] 	} -instance Eq Attr where+instance Eq DockerAttr where 	x == y = and-		[ _hostname x == _hostname y-		, _os x == _os y-		, _dns x == _dns y-		, _namedconf x == _namedconf y-		, _sshPubKey x == _sshPubKey y--		, _dockerImage x == _dockerImage y+		[ _dockerImage x == _dockerImage y 		, let simpl v = map (\a -> a "") (_dockerRunParams v) 		  in simpl x == simpl y 		] -instance Show Attr where+instance Monoid DockerAttr where+	mempty = DockerAttr mempty mempty+	mappend old new = DockerAttr+		{ _dockerImage = _dockerImage old <> _dockerImage new+		, _dockerRunParams = _dockerRunParams old <> _dockerRunParams new+		}++instance Show DockerAttr where 	show a = unlines-		[ "hostname " ++ _hostname a-		, "OS " ++ show (_os a)-		, "sshPubKey " ++ show (_sshPubKey a)-		, "dns " ++ show (_dns a)-		, "namedconf " ++ show (_namedconf a)-		, "docker image " ++ show (_dockerImage 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

@@ -3,6 +3,8 @@ 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 (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

@@ -24,7 +24,8 @@ hosts :: [Host] hosts = 	[ host "mybox.example.com"-		& Apt.stdSourcesList Unstable+		& os (System (Debian Unstable) "amd64")+		& Apt.stdSourcesList 		& Apt.unattendedUpgrades 		& Apt.installed ["etckeeper"] 		& Apt.installed ["ssh"]@@ -36,7 +37,9 @@ 		& Cron.runPropellor "30 * * * *"  	-- A generic webserver in a Docker container.-	, Docker.container "webserver" "joeyh/debian-unstable"+	, Docker.container "webserver" "joeyh/debian-stable"+		& os (System (Debian Stable) "amd64")+		& Apt.stdSourcesList 		& Docker.publish "80:80" 		& Docker.volume "/var/www:/var/www" 		& Apt.serviceInstalledRunning "apache2"