Merge branch 'joeyconfig'

2014-11-20 00:58:51 -04:00 · 2014-11-20 00:58:51 -04:00 · 02b8b2dec7
parent f1b2df601e 0d4dd37ee7
commit 02b8b2dec7
24 changed files with 777 additions and 566 deletions
--- a/config-joey.hs
+++ b/config-joey.hs
@ -24,6 +24,7 @@ import qualified Propellor.Property.Postfix as Postfix
 import qualified Propellor.Property.Grub as Grub
 import qualified Propellor.Property.Obnam as Obnam
 import qualified Propellor.Property.Gpg as Gpg
+import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
 import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
 import qualified Propellor.Property.HostingProvider.Linode as Linode
@ -44,7 +45,7 @@ hosts =                --                  (o)  `
 	, kite
 	, diatom
 	, elephant
-	] ++ containers ++ monsters
+	] ++ monsters

 darkstar :: Host
 darkstar = host "darkstar.kitenet.net"
@ -52,7 +53,7 @@ darkstar = host "darkstar.kitenet.net"

 	& Apt.buildDep ["git-annex"] `period` Daily
 	& Docker.configured
-	! Docker.docked hosts "android-git-annex"
+	! Docker.docked gitAnnexAndroidDev

 clam :: Host
 clam = standardSystem "clam.kitenet.net" Unstable "amd64"
@ -67,7 +68,7 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"

 	& Docker.configured
 	& Docker.garbageCollected `period` Daily
-	& Docker.docked hosts "webserver"
+	& Docker.docked webserver
 	& File.dirExists "/var/www/html"
 	& File.notPresent "/var/www/html/index.html"
 	& "/var/www/index.html" `File.hasContent` ["hello, world"]
@ -78,6 +79,8 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
 	& alias "travelling.kitenet.net"
 	! Ssh.listenPort 80
 	! Ssh.listenPort 443
+
+	! Debootstrap.built "/tmp/chroot" (System (Debian Unstable) "amd64") []
 	
 orca :: Host
 orca = standardSystem "orca.kitenet.net" Unstable "amd64"
@ -87,11 +90,11 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
 	& Apt.unattendedUpgrades
 	& Postfix.satellite
 	& Docker.configured
-	& Docker.docked hosts "amd64-git-annex-builder"
-	& Docker.docked hosts "i386-git-annex-builder"
-	& Docker.docked hosts "android-git-annex-builder"
-	& Docker.docked hosts "armel-git-annex-builder-companion"
-	& Docker.docked hosts "armel-git-annex-builder"
+	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h")
+	& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")
+	& Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage)
+	& Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h")
+	& Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h")
 	& Docker.garbageCollected `period` Daily
 	& Apt.buildDep ["git-annex"] `period` Daily
 	
@ -254,11 +257,10 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	& myDnsSecondary
 	
 	& Docker.configured
-		& Docker.docked hosts "oldusenet-shellbox"
-	& Docker.docked hosts "openid-provider"
+	& Docker.docked oldusenetShellBox
+	& Docker.docked openidProvider
 		`requires` Apt.serviceInstalledRunning "ntp"
-	& Docker.docked hosts "ancient-kitenet"
-
+	& Docker.docked ancientKitenet
 	& Docker.garbageCollected `period` (Weekly (Just 1))
 	
 	-- For https port 443, shellinabox with ssh login to
@ -280,48 +282,43 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
 	----------------------- :                    / -----------------------
 	------------------------ \____, o          ,' ------------------------
 	------------------------- '--,___________,'  -------------------------
-containers :: [Host]
-containers =
-	-- Simple web server, publishing the outside host's /var/www
-	[ standardStableContainer "webserver"
-		& Docker.publish "80:80"
-		& Docker.volume "/var/www:/var/www"
-		& Apt.serviceInstalledRunning "apache2"
+-- Simple web server, publishing the outside host's /var/www
+webserver :: Docker.Container
+webserver = standardStableContainer "webserver"
+	& Docker.publish "80:80"
+	& Docker.volume "/var/www:/var/www"
+	& Apt.serviceInstalledRunning "apache2"

-	-- My own openid provider. Uses php, so containerized for security
-	-- and administrative sanity.
-	, standardStableContainer "openid-provider"
-		& alias "openid.kitenet.net"
-		& Docker.publish "8081:80"
-		& OpenId.providerFor ["joey", "liw"]
-			"openid.kitenet.net:8081"
+-- My own openid provider. Uses php, so containerized for security
+-- and administrative sanity.
+openidProvider :: Docker.Container
+openidProvider = standardStableContainer "openid-provider"
+	& alias "openid.kitenet.net"
+	& Docker.publish "8081:80"
+	& OpenId.providerFor ["joey", "liw"]
+		"openid.kitenet.net:8081"

-	-- Exhibit: kite's 90's website.
-	, standardStableContainer "ancient-kitenet"
-		& 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")
-	
-	, standardStableContainer "oldusenet-shellbox"
-		& alias "shell.olduse.net"
-		& Docker.publish "4200:4200"
-		& JoeySites.oldUseNetShellBox
+-- Exhibit: kite's 90's website.
+ancientKitenet :: Docker.Container
+ancientKitenet = standardStableContainer "ancient-kitenet"
+	& 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")

-	-- git-annex autobuilder containers
-	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h"
-	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h"
-	, GitAnnexBuilder.armelCompanionContainer dockerImage
-	, GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h"
-	, GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h"
+oldusenetShellBox :: Docker.Container
+oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
+	& alias "shell.olduse.net"
+	& Docker.publish "4200:4200"
+	& JoeySites.oldUseNetShellBox

-	-- for development of git-annex for android, using my git-annex
-	-- work tree
-	, let gitannexdir = GitAnnexBuilder.homedir </> "git-annex"
-	  in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
-		& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)
-	]
+-- for development of git-annex for android, using my git-annex work tree
+gitAnnexAndroidDev :: Docker.Container
+gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
+	& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)
+  where
+	gitannexdir = GitAnnexBuilder.homedir </> "git-annex"

 type Motd = [String]

@ -355,11 +352,11 @@ standardSystemUnhardened hn suite arch motd = host hn
 	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
 		`onChange` Apt.autoRemove

-standardStableContainer :: Docker.ContainerName -> Host
+standardStableContainer :: Docker.ContainerName -> Docker.Container
 standardStableContainer name = standardContainer name (Stable "wheezy") "amd64"

 -- This is my standard container setup, featuring automatic upgrades.
-standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
 standardContainer name suite arch = Docker.container name (dockerImage system)
 	& os system
 	& Apt.stdSourcesList `onChange` Apt.upgrade
--- a/config-simple.hs
+++ b/config-simple.hs
@ -32,18 +32,19 @@ hosts =
 		& User.hasSomePassword "root" (Context "mybox.example.com")
 		& Network.ipv6to4
 		& File.dirExists "/var/www"
-		& Docker.docked hosts "webserver"
+		& Docker.docked webserverContainer
 		& Docker.garbageCollected `period` Daily
 		& Cron.runPropellor "30 * * * *"

-	-- A generic webserver in a Docker container.
-	, Docker.container "webserver" "joeyh/debian-stable"
-		& os (System (Debian (Stable "wheezy")) "amd64")
-		& Apt.stdSourcesList
-		& Docker.publish "80:80"
-		& Docker.volume "/var/www:/var/www"
-		& Apt.serviceInstalledRunning "apache2"
-
 	-- add more hosts here...
 	--, host "foo.example.com" = ...
 	]
+
+-- A generic webserver in a Docker container.
+webserverContainer :: Docker.Container
+webserverContainer = Docker.container "webserver" "joeyh/debian-stable"
+	& os (System (Debian (Stable "wheezy")) "amd64")
+	& Apt.stdSourcesList
+	& Docker.publish "80:80"
+	& Docker.volume "/var/www:/var/www"
+	& Apt.serviceInstalledRunning "apache2"
--- a/debian/changelog
+++ b/debian/changelog
@ -1,4 +1,4 @@
-propellor (0.9.3) UNRELEASED; urgency=medium
+propellor (1.0.0) UNRELEASED; urgency=medium

  * propellor --spin can now be used to update remote hosts, without
    any central git repository needed. The central git repository is
@ -9,13 +9,18 @@ propellor (0.9.3) UNRELEASED; urgency=medium
  * Can be used to configure tor hidden services. Thanks, Félix Sipma.
  * When multiple gpg keys are added, ensure that the privdata file
    can be decrypted by all of them.
-  * Convert GpgKeyId to newtype.
+  * Convert GpgKeyId to newtype. (API change)
  * DigitalOcean.distroKernel property now reboots into the distribution
    kernel when necessary.
  * Avoid outputting color setting sequences when not run on a terminal.
  * Run remote propellor --spin with a controlling terminal.
+  * Docker code simplified by using `docker exec`; needs docker 1.3.1.
+  * Docker containers are now a separate data type, cannot be included
+    in the main host list, and are instead passed to
+    Docker.docked. (API change)
+  * Added support for using debootstrap from propellor.

- -- Joey Hess <joeyh@debian.org>  Mon, 10 Nov 2014 11:15:27 -0400
+ -- Joey Hess <id@joeyh.name>  Mon, 10 Nov 2014 11:15:27 -0400

 propellor (0.9.2) unstable; urgency=medium

@ -32,7 +37,7 @@ propellor (0.9.1) unstable; urgency=medium

  * Docker: Add ability to control when containers restart.
  * Docker: Default to always restarting containers, so they come back 
-    up after reboots and docker daemon upgrades.
+    up after reboots and docker daemon upgrades. (API change)
  * Fix loop when a docker host that does not exist was docked.

 -- Joey Hess <joeyh@debian.org>  Fri, 24 Oct 2014 09:57:31 -0400
@ -45,7 +50,7 @@ propellor (0.9.0) unstable; urgency=medium
    Instead, the os property for a stable system includes the suite name
    to use, eg Stable "wheezy".
  * stdSourcesList uses the stable suite name, to avoid unwanted
-    immediate upgrades to the next stable release.
+    immediate upgrades to the next stable release. (API change)
  * debCdn switched from cdn.debian.net to http.debian.net, which seems to be
    better managed now.
  * Docker: Avoid committing container every time it's started up.
@ -120,7 +125,7 @@ propellor (0.7.0) unstable; urgency=medium
  * combineProperties no longer stops when a property fails; now it continues
    trying to satisfy all properties on the list before propigating the
    failure.
-  * Attr is renamed to Info.
+  * Attr is renamed to Info. (API change)
  * Renamed wrapper to propellor to make cabal installation of propellor work.
  * When git gpg signature of a fetched git branch cannot be verified,
    propellor will now continue running, but without merging in that branch.
@ -133,7 +138,7 @@ propellor (0.6.0) unstable; urgency=medium
    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.
+  * Apt.stdSourcesList no longer needs a suite to be specified. (API change)
  * 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
@ -176,7 +181,7 @@ propellor (0.5.1) unstable; urgency=medium
 propellor (0.5.0) unstable; urgency=medium

  * Removed root domain records from SOA. Instead, use RootDomain
-    when calling Dns.primary.
+    when calling Dns.primary. (API change)
  * Dns primary and secondary properties are now revertable.
  * When unattendedUpgrades is enabled on an Unstable or Testing system,
    configure it to allow the upgrades.
@ -190,8 +195,9 @@ propellor (0.4.0) unstable; urgency=medium
    zone files, which is done by looking at the properties of hosts
    in a domain.
  * The `cname` property was renamed to `alias` as it does not always
-    generate CNAME in the DNS.
+    generate CNAME in the DNS. (API change)
  * Constructor of Property has changed (use `property` function instead).
+    (API change)
  * All Property combinators now combine together their Attr settings.
    So Attr settings can be made inside a propertyList, for example.
  * Run all cron jobs under chronic from moreutils to avoid unnecessary
@ -227,7 +233,7 @@ propellor (0.3.0) unstable; urgency=medium
  * Include security updates in sources.list for stable and testing.
  * Use ssh connection caching, especially when bootstrapping.
  * Properties now run in a Propellor monad, which provides access to
-    attributes of the host.
+    attributes of the host. (API change)

 -- Joey Hess <joeyh@debian.org>  Fri, 11 Apr 2014 01:19:05 -0400

--- a/propellor.cabal
+++ b/propellor.cabal
@ -1,5 +1,5 @@
 Name: propellor
-Version: 0.9.3
+Version: 1.0.0
 Cabal-Version: >= 1.6
 License: BSD3
 Maintainer: Joey Hess <joey@kitenet.net>
@ -75,6 +75,7 @@ Library
    Propellor.Property.Cmd
    Propellor.Property.Hostname
    Propellor.Property.Cron
+    Propellor.Property.Debootstrap
    Propellor.Property.Dns
    Propellor.Property.Docker
    Propellor.Property.File
@ -101,6 +102,7 @@ Library
    Propellor.Property.SiteSpecific.GitHome
    Propellor.Property.SiteSpecific.JoeySites
    Propellor.Property.SiteSpecific.GitAnnexBuilder
+    Propellor.CmdLine
    Propellor.Info
    Propellor.Message
    Propellor.PrivData
@ -111,11 +113,9 @@ Library
    Propellor.Types.Dns
    Propellor.Types.PrivData
  Other-Modules:
-    Propellor.Types.Info
-    Propellor.CmdLine
    Propellor.Git
    Propellor.Gpg
-    Propellor.SimpleSh
+    Propellor.Server
    Propellor.Ssh
    Propellor.PrivData.Paths
    Propellor.Protocol
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@ -1,24 +1,21 @@
-module Propellor.CmdLine where
+module Propellor.CmdLine (
+	defaultMain,
+	processCmdLine,
+) where

 import System.Environment (getArgs)
 import Data.List
 import System.Exit
 import System.PosixCompat
-import Control.Exception (bracket)
-import System.Posix.IO
-import Control.Concurrent.Async
-import qualified Data.ByteString as B
-import System.Process (std_in, std_out)

 import Propellor
 import Propellor.Protocol
-import Propellor.PrivData.Paths
 import Propellor.Gpg
 import Propellor.Git
 import Propellor.Ssh
+import Propellor.Server
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Docker.Shim as DockerShim
-import Utility.FileMode
 import Utility.SafeCommand

 usage :: Handle -> IO ()
@ -72,6 +69,7 @@ processCmdLine = go =<< getArgs
 		Just pf -> return $ f pf (Context c)
 		Nothing -> errorMessage $ "Unknown privdata field " ++ s

+-- | Runs propellor on hosts, as controlled by command-line options.
 defaultMain :: [Host] -> IO ()
 defaultMain hostlist = do
 	DockerShim.cleanEnv
@ -86,39 +84,24 @@ defaultMain hostlist = do
 	go _ (Edit field context) = editPrivData field context
 	go _ ListFields = listPrivDataFields hostlist
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain hn isconsole) = withhost hn $ \h -> do
-		when isconsole forceConsole
-		r <- runPropellor h $ ensureProperties $ hostProperties h
-		putStrLn $ "\n" ++ show r
-	go _ (Docker hn) = Docker.chain hn
-	go _ (GitPush fin fout) = gitPush fin fout
+	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
+	go _ (DockerInit hn) = Docker.init hn
+	go _ (GitPush fin fout) = gitPushHelper fin fout
+	go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
 	go False (Spin hn) = withhost hn $ spin hn
 	go False cmdline@(SimpleRun hn) = buildFirst cmdline $
 		go False (Run hn)
 	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withhost hn mainProperties
+		( onlyprocess $ withhost hn mainProperties
 		, go True (Spin hn)
 		)
-	go False (Update _) = do
-		forceConsole
-		onlyProcess update

 	withhost :: HostName -> (Host -> IO ()) -> IO ()
 	withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
-
-onlyProcess :: IO a -> IO a
-onlyProcess a = bracket lock unlock (const a)
-  where
-	lock = do
-		l <- createFile lockfile stdFileMode
-		setLock l (WriteLock, AbsoluteSeek, 0, 0)
-			`catchIO` const alreadyrunning
-		return l
-	unlock = closeFd
-	alreadyrunning = error "Propellor is already running on this host!"
-	lockfile = localdir </> ".lock"
+	
+	onlyprocess = onlyProcess (localdir </> ".lock")

 unknownhost :: HostName -> [Host] -> IO a
 unknownhost h hosts = errorMessage $ unlines
@ -142,42 +125,27 @@ buildFirst cmdline next = do
  where
 	getmtime = catchMaybeIO $ getModificationTime "propellor"

+fetchFirst :: IO () -> IO ()
+fetchFirst next = do
+	whenM hasOrigin $
+		void fetchOrigin
+	next
+
 updateFirst :: CmdLine -> IO () -> IO ()
 updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)

 updateFirst' :: CmdLine -> IO () -> IO ()
-updateFirst' cmdline next = do
-	branchref <- getCurrentBranch
-	let originbranch = "origin" </> branchref
-
-	void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
-	
-	oldsha <- getCurrentGitSha1 branchref
-	
-	whenM (doesFileExist keyring) $
-		ifM (verifyOriginBranch originbranch)
-			( do
-				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
-				hFlush stdout
-				void $ boolSystem "git" [Param "merge", Param originbranch]
-			, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
-			)
-	
-	newsha <- getCurrentGitSha1 branchref
-
-	if oldsha == newsha
-		then next
-		else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
-			( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
+updateFirst' cmdline next = ifM fetchOrigin
+	( ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
+		( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
 			, errorMessage "Propellor build failed!" 
-			)
+		)
+	, next
+	)

-- spin handles deploying propellor to a remote host, if it's not already
-- installed there, or updating it if it is. Once the remote propellor is
-- updated, it's run.
 spin :: HostName -> Host -> IO ()
 spin hn hst = do
-	void $ actionMessage "Git commit (signed)" $
+	void $ actionMessage "Git commit" $
 		gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
 	-- Push to central origin repo first, if possible.
 	-- The remote propellor will pull from there, which avoids
@ -187,16 +155,20 @@ spin hn hst = do
 			boolSystem "git" [Param "push"]
 	
 	cacheparams <- toCommand <$> sshCachingParams hn
-	comm hn hst $ withBothHandles createProcessSuccess
-		(proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
+
+	-- Install, or update the remote propellor.
+	updateServer hn hst $ withBothHandles createProcessSuccess
+		(proc "ssh" $ cacheparams ++ [user, updatecmd])
+
+	-- And now we can run it.
 	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
-		error $ "remote propellor failed (running: " ++ runcmd ++")"
+		error $ "remote propellor failed"
  where
 	user = "root@"++hn

 	mkcmd = shellWrap . intercalate " ; "

-	bootstrapcmd = mkcmd
+	updatecmd = mkcmd
 		[ "if [ ! -d " ++ localdir ++ " ]"
 		, "then " ++ intercalate " && "
 			[ "apt-get update"
@ -213,119 +185,3 @@ spin hn hst = do

 	runcmd = mkcmd
 		[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
-
-- Update the privdata, repo url, and git repo over the ssh
-- connection from the client that ran propellor --spin.
-update :: IO ()
-update = do
-	req NeedRepoUrl repoUrlMarker setRepoUrl
-	makePrivDataDir
-	req NeedPrivData privDataMarker $
-		writeFileProtected privDataLocal
-	req NeedGitPush gitPushMarker $ \_ -> do
-		hin <- dup stdInput
-		hout <- dup stdOutput
-		hClose stdin
-		hClose stdout
-		unlessM (boolSystem "git" (pullparams hin hout)) $
-			errorMessage "git pull from client failed"
-  where
-	pullparams hin hout =
-		[ Param "pull"
-		, Param "--progress"
-		, Param "--upload-pack"
-		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
-		, Param "."
-		]
-
-comm :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
-comm hn hst connect = connect go
-  where
-	go (toh, fromh) = do
-		let loop = go (toh, fromh)
-		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
-		case v of
-			(Just NeedRepoUrl) -> do
-				sendRepoUrl toh
-				loop
-			(Just NeedPrivData) -> do
-				sendPrivData hn hst toh
-				loop
-			(Just NeedGitPush) -> do
-				sendGitUpdate hn fromh toh
-				-- no more protocol possible after git push
-				hClose fromh
-				hClose toh
-			(Just NeedGitClone) -> do
-				hClose toh
-				hClose fromh
-				sendGitClone hn
-				comm hn hst connect
-			Nothing -> return ()
-
-sendRepoUrl :: Handle -> IO ()
-sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
-
-sendPrivData :: HostName -> Host -> Handle -> IO ()
-sendPrivData hn hst toh = do
-	privdata <- show . filterPrivData hst <$> decryptPrivData
-	void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
-		sendMarked toh privDataMarker privdata
-		return True
-
-sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
-sendGitUpdate hn fromh toh =
-	void $ actionMessage ("Sending git update to " ++ hn) $ do
-		sendMarked toh gitPushMarker ""
-		(Nothing, Nothing, Nothing, h) <- createProcess p
-		(==) ExitSuccess <$> waitForProcess h
-  where
-	p = (proc "git" ["upload-pack", "."])
-		{ std_in = UseHandle fromh
-		, std_out = UseHandle toh
-		}
-
-- Initial git clone, used for bootstrapping.
-sendGitClone :: HostName -> IO ()
-sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
-	branch <- getCurrentBranch
-	cacheparams <- sshCachingParams hn
-	withTmpFile "propellor.git" $ \tmp _ -> allM id
-		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
-		]
-  where
-	remotebundle = "/usr/local/propellor.git"
-	unpackcmd branch = shellWrap $ intercalate " && "
-		[ "git clone " ++ remotebundle ++ " " ++ localdir
-		, "cd " ++ localdir
-		, "git checkout -b " ++ branch
-		, "git remote rm origin"
-		, "rm -f " ++ remotebundle
-		]
-
-- Shim for git push over the propellor ssh channel.
-- Reads from stdin and sends it to hout;
-- reads from hin and sends it to stdout.
-gitPush :: Fd -> Fd -> IO ()
-gitPush hin hout = void $ fromstdin `concurrently` tostdout
-  where
-	fromstdin = do
-		h <- fdToHandle hout
-		connect stdin h
-	tostdout = do
-		h <- fdToHandle hin
-		connect h stdout
-	connect fromh toh = do
-		hSetBinaryMode fromh True
-		hSetBinaryMode toh True
-		b <- B.hGetSome fromh 40960
-		if B.null b
-			then do
-				hClose fromh
-				hClose toh
-			else do
-				B.hPut toh b
-				hFlush toh
-				connect fromh toh
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@ -8,11 +8,15 @@ import Data.Monoid
 import Control.Applicative
 import System.Console.ANSI
 import "mtl" Control.Monad.Reader
+import Control.Exception (bracket)
+import System.PosixCompat
+import System.Posix.IO

 import Propellor.Types
 import Propellor.Message
 import Propellor.Exception
 import Propellor.Info
+import Utility.Exception

 runPropellor :: Host -> Propellor a -> IO a
 runPropellor host a = runReaderT (runWithHost a) host
@ -47,3 +51,14 @@ fromHost l hn getter = case findHost l hn of
 	Nothing -> return Nothing
 	Just h -> liftIO $ Just <$>
 		runReaderT (runWithHost getter) h
+
+onlyProcess :: FilePath -> IO a -> IO a
+onlyProcess lockfile a = bracket lock unlock (const a)
+  where
+	lock = do
+		l <- createFile lockfile stdFileMode
+		setLock l (WriteLock, AbsoluteSeek, 0, 0)
+			`catchIO` const alreadyrunning
+		return l
+	unlock = closeFd
+	alreadyrunning = error "Propellor is already running on this host!"
--- a/src/Propellor/Git.hs
+++ b/src/Propellor/Git.hs
@ -62,3 +62,26 @@ verifyOriginBranch originbranch = do
 	nukeFile $ privDataDir </> "pubring.gpg"
 	nukeFile $ privDataDir </> "gpg.conf"
 	return (s == "U\n" || s == "G\n")
+
+-- Returns True if HEAD is changed by fetching and merging from origin.
+fetchOrigin :: IO Bool
+fetchOrigin = do
+	branchref <- getCurrentBranch
+	let originbranch = "origin" </> branchref
+
+	void $ actionMessage "Pull from central git repository" $
+		boolSystem "git" [Param "fetch"]
+	
+	oldsha <- getCurrentGitSha1 branchref
+	
+	whenM (doesFileExist keyring) $
+		ifM (verifyOriginBranch originbranch)
+			( do
+				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
+				hFlush stdout
+				void $ boolSystem "git" [Param "merge", Param originbranch]
+			, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
+			)
+	
+	newsha <- getCurrentGitSha1 branchref
+	return $ oldsha /= newsha
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@ -3,7 +3,6 @@
 module Propellor.Info where

 import Propellor.Types
-import Propellor.Types.Info

 import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@ -21,10 +21,11 @@ data MessageHandle
 	| TextMessageHandle

 mkMessageHandle :: IO MessageHandle
-mkMessageHandle = ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
-	( return ConsoleMessageHandle
-	, return TextMessageHandle
-	)
+mkMessageHandle = do
+	ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
+		( return ConsoleMessageHandle
+		, return TextMessageHandle
+		)

 forceConsole :: IO ()
 forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@ -15,7 +15,6 @@ import qualified Data.Map as M
 import qualified Data.Set as S

 import Propellor.Types
-import Propellor.Types.Info
 import Propellor.Message
 import Propellor.Info
 import Propellor.Gpg
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@ -89,6 +89,15 @@ check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
 	, return NoChange
 	)

+-- | Tries the first property, but if it fails to work, instead uses
+-- the second.
+fallback :: Property -> Property -> Property
+fallback p1 p2 = adjustProperty p1 $ \satisfy -> do
+	r <- satisfy
+	if r == FailedChange
+		then propertySatisfy p2
+		else return r
+
 -- | Marks a Property as trivial. It can only return FailedChange or
 -- NoChange. 
 --
@ -122,6 +131,10 @@ boolProperty desc a = property desc $ ifM (liftIO a)
 revert :: RevertableProperty -> RevertableProperty
 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1

+-- | Turns a revertable property into a regular property.
+unrevertable :: RevertableProperty -> Property
+unrevertable (RevertableProperty p1 _p2) = p1
+
 -- | Starts accumulating the properties of a Host.
 --
 -- > host "example.com"
@ -131,27 +144,28 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
 host :: HostName -> Host
 host hn = Host hn [] mempty

-- | Adds a property to a Host
--
-- Can add Properties and RevertableProperties
-(&) :: IsProp p => Host -> p -> Host
-(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
+class Hostlike h where
+	-- | Adds a property to a Host
+	--
+	-- Can add Properties and RevertableProperties
+	(&) :: IsProp p => h -> p -> h
+	-- | Like (&), but adds the property as the
+	-- first property of the host. Normally, property
+	-- order should not matter, but this is useful
+	-- when it does.
+	(&^) :: IsProp p => h -> p -> h

-infixl 1 &
+instance Hostlike Host where
+	(Host hn ps is) &  p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
+	(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)

 -- | Adds a property to the Host in reverted form.
-(!) :: Host -> RevertableProperty -> Host
+(!) :: Hostlike h => h -> RevertableProperty -> h
 h ! p = h & revert p

-infixl 1 !
-
-- | Like (&), but adds the property as the first property of the host.
-- Normally, property order should not matter, but this is useful
-- when it does.
-(&^) :: IsProp p => Host -> p -> Host
-(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
-
 infixl 1 &^
+infixl 1 &
+infixl 1 !

 -- Changes the action that is performed to satisfy a property. 
 adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@ -0,0 +1,253 @@
+module Propellor.Property.Debootstrap (
+	Url,
+	built,
+	installed,
+	programPath,
+) where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import Utility.Path
+import Utility.SafeCommand
+import Utility.FileMode
+
+import Data.List
+import Data.Char
+import Control.Exception
+import System.Posix.Directory
+
+type Url = String
+
+-- | Builds a chroot in the given directory using debootstrap.
+--
+-- The System can be any OS and architecture that debootstrap
+-- and the kernel support.
+--
+-- Reverting this property deletes the chroot and all its contents.
+-- Anything mounted under the filesystem is first unmounted.
+--
+-- Note that reverting this property does not stop any processes
+-- currently running in the chroot.
+built :: FilePath -> System -> [CommandParam] -> RevertableProperty
+built target system@(System _ arch) extraparams =
+	RevertableProperty setup teardown
+  where
+	setup = check (unpopulated target <||> ispartial) setupprop
+		`requires` unrevertable installed
+	
+	teardown = check (not <$> unpopulated target) teardownprop
+	
+	unpopulated d = null <$> catchDefaultIO [] (dirContents d)
+
+	setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
+		createDirectoryIfMissing True target
+		suite <- case extractSuite system of
+			Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
+			Just s -> pure s
+		let params = extraparams ++
+			[ Param $ "--arch=" ++ arch
+			, Param suite
+			, Param target
+			]
+		cmd <- fromMaybe "debootstrap" <$> programPath
+		ifM (boolSystem cmd params)
+			( do
+				fixForeignDev target
+				return MadeChange
+			, return FailedChange
+			)
+
+	teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do
+		removetarget
+		return MadeChange
+
+	removetarget = do
+		submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
+			. filter (dirContains target)
+			<$> mountPoints
+		forM_ submnts $ \mnt ->
+			unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do
+				errorMessage $ "failed unmounting " ++ mnt
+		removeDirectoryRecursive target
+
+	-- A failed debootstrap run will leave a debootstrap directory;
+	-- recover by deleting it and trying again.
+	ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
+		( do
+			removetarget
+			return True
+		, return False
+		)
+
+mountPoints :: IO [FilePath]
+mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
+
+extractSuite :: System -> Maybe String
+extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
+extractSuite (System (Ubuntu r) _) = Just r
+
+-- | Ensures debootstrap is installed.
+--
+-- When necessary, falls back to installing debootstrap from source.
+-- Note that installation from source is done by downloading the tarball
+-- from a Debian mirror, with no cryptographic verification.
+installed :: RevertableProperty
+installed = RevertableProperty install remove
+  where
+	install = withOS "debootstrap installed" $ \o -> 
+		ifM (liftIO $ isJust <$> programPath)
+			( return NoChange
+			, ensureProperty (installon o)
+			)
+
+	installon (Just (System (Debian _) _)) = aptinstall
+	installon (Just (System (Ubuntu _) _)) = aptinstall
+	installon _ = sourceInstall
+
+	remove = withOS "debootstrap removed" $ ensureProperty . removefrom
+	removefrom (Just (System (Debian _) _)) = aptremove
+	removefrom (Just (System (Ubuntu _) _)) = aptremove
+	removefrom _ = sourceRemove
+			
+	aptinstall = Apt.installed ["debootstrap"]
+	aptremove = Apt.removed ["debootstrap"]
+
+sourceInstall :: Property
+sourceInstall = property "debootstrap installed from source"
+	(liftIO sourceInstall')
+
+sourceInstall' :: IO Result
+sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
+	let indexfile = tmpd </> "index.html"
+	unlessM (download baseurl indexfile) $
+		errorMessage $ "Failed to download " ++ baseurl
+	urls <- reverse . sort -- highest version first
+		. filter ("debootstrap_" `isInfixOf`)
+		. filter (".tar." `isInfixOf`)
+		. extractUrls baseurl <$>
+		readFileStrictAnyEncoding indexfile
+	nukeFile indexfile
+
+	tarfile <- case urls of
+		(tarurl:_) -> do
+			let f = tmpd </> takeFileName tarurl
+			unlessM (download tarurl f) $
+				errorMessage $ "Failed to download " ++ tarurl
+			return f
+		_ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl
+
+	createDirectoryIfMissing True localInstallDir
+	bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do
+		changeWorkingDirectory localInstallDir
+		unlessM (boolSystem "tar" [Param "xf", File tarfile]) $
+			errorMessage "Failed to extract debootstrap tar file"
+		nukeFile tarfile
+		l <- dirContents "."
+		case l of
+			(subdir:[]) -> do
+				changeWorkingDirectory subdir
+				makeDevicesTarball
+				makeWrapperScript (localInstallDir </> subdir)
+				return MadeChange
+			_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
+
+sourceRemove :: Property
+sourceRemove = property "debootstrap not installed from source" $ liftIO $
+	ifM (doesDirectoryExist sourceInstallDir)
+		( do
+			removeDirectoryRecursive sourceInstallDir
+			return MadeChange
+		, return NoChange
+		)
+
+sourceInstallDir :: FilePath
+sourceInstallDir = "/usr/local/propellor/debootstrap"
+
+wrapperScript :: FilePath
+wrapperScript = sourceInstallDir </> "debootstrap.wrapper"
+
+-- | Finds debootstrap in PATH, but fall back to looking for the
+-- wrapper script that is installed, outside the PATH, when debootstrap
+-- is installed from source.
+programPath :: IO (Maybe FilePath)
+programPath = getM searchPath
+	[ "debootstrap"
+	, wrapperScript
+	]
+
+makeWrapperScript :: FilePath -> IO ()
+makeWrapperScript dir = do
+	createDirectoryIfMissing True (takeDirectory wrapperScript)
+	writeFile wrapperScript $ unlines
+		[ "#!/bin/sh"
+		, "set -e"
+		, "DEBOOTSTRAP_DIR=" ++ dir
+		, "export DEBOOTSTRAP_DIR"
+		, dir </> "debootstrap" ++ " \"$@\""
+		]
+	modifyFileMode wrapperScript (addModes $ readModes ++ executeModes)
+
+-- Work around for http://bugs.debian.org/770217
+makeDevicesTarball :: IO ()
+makeDevicesTarball = do
+	-- TODO append to tarball; avoid writing to /dev
+	writeFile foreignDevFlag "1"
+	ok <- boolSystem "sh" [Param "-c", Param tarcmd]
+	nukeFile foreignDevFlag
+	unless ok $
+		errorMessage "Failed to tar up /dev to generate devices.tar.gz"
+  where
+	tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz"
+
+fixForeignDev :: FilePath -> IO ()
+fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ 
+	void $ boolSystem "chroot"
+		[ File target
+		, Param "sh"
+		, Param "-c"
+		, Param $ intercalate " && "
+			[ "rm -rf /dev"
+			, "mkdir /dev"
+			, "cd /dev"
+			, "/sbin/MAKEDEV std ptmx fd consoleonly"
+			]
+		]
+
+foreignDevFlag :: FilePath
+foreignDevFlag = "/dev/.propellor-foreign-dev"
+
+localInstallDir :: FilePath
+localInstallDir = "/usr/local/debootstrap"
+
+-- This http server directory listing is relied on to be fairly sane,
+-- which is one reason why it's using a specific server and not a
+-- round-robin address.
+baseurl :: Url
+baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/"
+
+download :: Url -> FilePath -> IO Bool
+download url dest = anyM id
+	[ boolSystem "curl" [Param "-o", File dest, Param url]
+	, boolSystem "wget" [Param "-O", File dest, Param url]
+	]
+
+-- Pretty hackish, but I don't want to pull in a whole html parser
+-- or parsec dependency just for this.
+--
+-- To simplify parsing, lower case everything. This is ok because
+-- the filenames are all lower-case anyway.
+extractUrls :: Url -> String -> [Url]
+extractUrls base = collect [] . map toLower
+  where
+	collect l [] = l
+	collect l ('h':'r':'e':'f':'=':r) = case r of
+		('"':r') -> findend l r'
+		_ -> findend l r
+	collect l (_:cs) = collect l cs
+
+	findend l s = 
+		let (u, r) = break (== '"') s
+		    u' = if "http" `isPrefixOf` u
+		    	then u
+			else base </> u
+		in collect (u':l) r
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@ -15,7 +15,6 @@ module Propellor.Property.Dns (
 import Propellor
 import Propellor.Types.Dns
 import Propellor.Property.File
-import Propellor.Types.Info
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Service as Service
 import Utility.Applicative
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@ -16,6 +16,7 @@ module Propellor.Property.Docker (
 	tweaked,
 	Image,
 	ContainerName,
+	Container,
 	-- * Container configuration
 	dns,
 	hostname,
@ -33,24 +34,26 @@ module Propellor.Property.Docker (
 	restartOnFailure,
 	restartNever,
 	-- * Internal use
+	init,
 	chain,
 ) where

-import Propellor
-import Propellor.SimpleSh
-import Propellor.Types.Info
+import Propellor hiding (init)
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Docker.Shim as Shim
 import Utility.SafeCommand
 import Utility.Path
+import Utility.ThreadScheduler

 import Control.Concurrent.Async hiding (link)
 import System.Posix.Directory
 import System.Posix.Process
-import Data.List
+import Prelude hiding (init)
+import Data.List hiding (init)
 import Data.List.Utils
 import qualified Data.Set as S
+import qualified Data.Map as M

 installed :: Property
 installed = Apt.installed ["docker.io"]
@ -69,55 +72,56 @@ configured = prop `requires` installed
 -- only [a-zA-Z0-9_-] are allowed
 type ContainerName = String

-- | Starts accumulating the properties of a Docker container.
+-- | A docker container.
+data Container = Container Image Host
+
+instance Hostlike Container where
+	(Container i h) & p = Container i (h & p)
+	(Container i h) &^ p = Container i (h &^ p)
+
+-- | Builds a Container with a given name, image, and properties.
 --
 -- > container "web-server" "debian"
 -- >    & publish "80:80"
 -- >    & Apt.installed {"apache2"]
 -- >    & ...
-container :: ContainerName -> Image -> Host
-container cn image = Host hn [] info
+container :: ContainerName -> Image -> Container
+container cn image = Container image (Host cn [] info)
  where
-	info = dockerInfo $ mempty { _dockerImage = Val image }
-	hn = cn2hn cn
+	info = dockerInfo mempty

-cn2hn :: ContainerName -> HostName
-cn2hn cn = cn ++ ".docker"
-
-- | Ensures that a docker container is set up and running, finding
-- its configuration in the passed list of hosts.
+-- | 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.
 --
 -- When the container's Properties include DNS info, such as a CNAME,
-- that is propigated to the Info of the host(s) it's docked in.
+-- that is propigated to the Info of the Host it's docked in.
 --
 -- Reverting this property ensures that the container is stopped and
 -- removed.
 docked
-	:: [Host]
-	-> ContainerName
+	:: Container
 	-> RevertableProperty
-docked hosts cn = RevertableProperty
-	((maybe id propigateInfo mhost) (go "docked" setup))
+docked ctr@(Container _ h) = RevertableProperty
+	(propigateInfo ctr (go "docked" setup))
 	(go "undocked" teardown)
  where
+	cn = hostName h
+
 	go desc a = property (desc ++ " " ++ cn) $ do
 		hn <- asks hostName
 		let cid = ContainerId hn cn
-		ensureProperties [findContainer mhost cid cn $ a cid]
-		
-	mhost = findHostNoAlias hosts (cn2hn cn)
+		ensureProperties [a cid (mkContainerInfo cid ctr)]

-	setup cid (Container image runparams) =
+	setup cid (ContainerInfo image runparams) =
 		provisionContainer cid
 			`requires`
 		runningContainer cid image runparams
 			`requires`
 		installed

-	teardown cid (Container image _runparams) =
+	teardown cid (ContainerInfo image _runparams) =
 		combineProperties ("undocked " ++ fromContainerId cid)
 			[ stoppedContainer cid
 			, property ("cleaned up " ++ fromContainerId cid) $
@ -127,33 +131,21 @@ docked hosts cn = RevertableProperty
 					]
 			]

-propigateInfo :: Host -> Property -> Property
-propigateInfo (Host _ _ containerinfo) p =
-	combineProperties (propertyDesc p) $ p : dnsprops ++ privprops
+propigateInfo :: Container -> Property -> Property
+propigateInfo (Container _ h@(Host hn _ containerinfo)) p =
+	combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops
  where
+	p' = p { propertyInfo = propertyInfo p <> dockerinfo }
+	dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h }
 	dnsprops = map addDNS (S.toList $ _dns containerinfo)
 	privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)

-findContainer
-	:: Maybe Host
-	-> ContainerId
-	-> ContainerName
-	-> (Container -> Property)
-	-> Property
-findContainer mhost cid cn mk = case mhost of
-	Nothing -> cantfind
-	Just h -> maybe cantfind mk (mkContainer cid h)
-  where
-	cantfind = containerDesc cid $ property "" $ do
-		liftIO $ warningMessage $
-			"missing definition for docker container \"" ++ cn2hn cn
-		return FailedChange
-
-mkContainer :: ContainerId -> Host -> Maybe Container
-mkContainer cid@(ContainerId hn _cn) h = Container
-	<$> fromVal (_dockerImage info)
-	<*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info))
+mkContainerInfo :: ContainerId -> Container -> ContainerInfo
+mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = 
+	ContainerInfo img runparams
  where
+	runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
+		(_dockerRunParams info)
 	info = _dockerinfo $ hostInfo h'
 	h' = h
 		-- Restart by default so container comes up on
@ -207,7 +199,7 @@ memoryLimited = "/etc/default/grub" `File.containsLine` cfg
 	cmdline = "cgroup_enable=memory swapaccount=1"
 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""

-data Container = Container Image [RunParam]
+data ContainerInfo = ContainerInfo Image [RunParam]

 -- | Parameters to pass to `docker run` when creating a container.
 type RunParam = String
@ -301,7 +293,10 @@ restartNever = runProp "restart" "no"

 -- | A container is identified by its name, and the host
 -- on which it's deployed.
-data ContainerId = ContainerId HostName ContainerName
+data ContainerId = ContainerId 
+	{ containerHostName :: HostName
+	, containerName :: ContainerName
+	}
 	deriving (Eq, Read, Show)

 -- | Two containers with the same ContainerIdent were started from
@ -324,22 +319,19 @@ toContainerId s
 fromContainerId :: ContainerId -> String
 fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix

-containerHostName :: ContainerId -> HostName
-containerHostName (ContainerId _ cn) = cn2hn cn
-
 myContainerSuffix :: String
 myContainerSuffix = ".propellor"

 containerDesc :: ContainerId -> Property -> Property
 containerDesc cid p = p `describe` desc
  where
-	desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
+	desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p

 runningContainer :: ContainerId -> Image -> [RunParam] -> Property
 runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
 	l <- liftIO $ listContainers RunningContainers
 	if cid `elem` l
-		then checkident =<< liftIO (getrunningident simpleShClient)
+		then checkident =<< liftIO getrunningident
 		else ifM (liftIO $ elem cid <$> listContainers AllContainers)
 			( do
 				-- The container exists, but is not
@ -348,9 +340,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 				-- starting it up first.
 				void $ liftIO $ startContainer cid
 				-- It can take a while for the container to
-				-- start up enough to get its ident, so
-				-- retry for up to 60 seconds.
-				checkident =<< liftIO (getrunningident (simpleShClientRetry 60))
+				-- start up enough for its ident file to be
+				-- written, so retry for up to 60 seconds.
+				checkident =<< liftIO (retry 60 $ getrunningident)
 			, go image
 			)
  where
@ -370,12 +362,18 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 		void $ liftIO $ removeContainer cid
 		go oldimage

-	getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
-		let !v = extractident rs
-		return v
+	getrunningident = readish
+		<$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent])

-	extractident :: [Resp] -> Maybe ContainerIdent
-	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
+	retry :: Int -> IO (Maybe a) -> IO (Maybe a)
+	retry 0 _ = return Nothing
+	retry n a = do
+		v <- a
+		case v of
+			Just _ -> return v
+			Nothing -> do
+				threadDelaySeconds (Seconds 1)				
+				retry (n-1) a

 	go img = do
 		liftIO $ do
@ -385,7 +383,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 		liftIO $ writeFile (identFile cid) (show ident)
 		ensureProperty $ boolProperty "run" $ runContainer img
 			(runps ++ ["-i", "-d", "-t"])
-			[shim, "--continue", show (Docker (fromContainerId cid))]
+			[shim, "--continue", show (DockerInit (fromContainerId cid))]

 -- | Called when propellor is running inside a docker container.
 -- The string should be the container's ContainerId.
@ -393,7 +391,6 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 -- This process is effectively init inside the container.
 -- It even needs to wait on zombie processes!
 --
-- Fork a thread to run the SimpleSh server in the background.
 -- In the foreground, run an interactive bash (or sh) shell,
 -- so that the user can interact with it when attached to the container.
 --
@ -401,25 +398,22 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 -- again. So, to make the necessary services get started on boot, this needs
 -- to provision the container then. However, if the container is already
 -- being provisioned by the calling propellor, it would be redundant and
-- problimatic to also provisoon it here.
+-- problimatic to also provisoon it here, when not booting up.
 --
 -- The solution is a flag file. If the flag file exists, then the container
 -- was already provisioned. So, it must be a reboot, and time to provision
 -- again. If the flag file doesn't exist, don't provision here.
-chain :: String -> IO ()
-chain s = case toContainerId s of
+init :: String -> IO ()
+init s = case toContainerId s of
 	Nothing -> error $ "Invalid ContainerId: " ++ s
 	Just cid -> do
 		changeWorkingDirectory localdir
 		writeFile propellorIdent . show =<< readIdentFile cid
-		-- Run boot provisioning before starting simpleSh,
-		-- to avoid ever provisioning twice at the same time.
 		whenM (checkProvisionedFlag cid) $ do
 			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
-			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid) False]) $
+			unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $
 				warningMessage "Boot provision failed!"
 		void $ async $ job reapzombies
-		void $ async $ job $ simpleSh $ namedPipe cid
 		job $ do
 			void $ tryIO $ ifM (inPath "bash")
 				( boolSystem "bash" [Param "-l"]
@ -432,36 +426,47 @@ chain s = case toContainerId s of

 -- | Once a container is running, propellor can be run inside
 -- it to provision it.
--
-- Note that there is a race here, between the simplesh
-- server starting up in the container, and this property
-- being run. So, retry connections to the client for up to
-- 1 minute.
 provisionContainer :: ContainerId -> Property
 provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+	let params = ["--continue", show $ toChain cid]
 	msgh <- mkMessageHandle
-	let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)]
-	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
+	let p = inContainerProcess cid
+		[ if isConsole msgh then "-it" else "-i" ]
+		(shim : params)
+	r <- withHandle StdoutHandle createProcessSuccess p $
+		processoutput Nothing
 	when (r /= FailedChange) $
 		setProvisionedFlag cid 
 	return r
  where
-	go lastline (v:rest) = case v of
-		StdoutLine s -> do
-			maybe noop putStrLn lastline
-			hFlush stdout
-			go (Just s) rest
-		StderrLine s -> do
-			maybe noop putStrLn lastline
-			hFlush stdout
-			hPutStrLn stderr s
-			hFlush stderr
-			go Nothing rest
-		Done -> ret lastline
-	go lastline [] = ret lastline
+	processoutput lastline h = do
+		v <- catchMaybeIO (hGetLine h)
+		case v of
+			Nothing -> pure $ fromMaybe FailedChange $
+				readish =<< lastline
+			Just s -> do
+				maybe noop putStrLn lastline
+				hFlush stdout
+				processoutput (Just s) h

-	ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
+toChain :: ContainerId -> CmdLine
+toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
+
+chain :: [Host] -> HostName -> String -> IO ()
+chain hostlist hn s = case toContainerId s of
+	Nothing -> errorMessage "bad container id"
+	Just cid -> case findHostNoAlias hostlist hn of
+		Nothing -> errorMessage ("cannot find host " ++ hn)
+		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ _dockerinfo $ hostInfo parenthost) of
+			Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
+			Just h -> go cid h
+  where
+	go cid h = do
+		changeWorkingDirectory localdir
+		onlyProcess (provisioningLock cid) $ do
+			r <- runPropellor h $ ensureProperties $ hostProperties h
+			putStrLn $ "\n" ++ show r

 stopContainer :: ContainerId -> IO Bool
 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
@ -479,7 +484,6 @@ stoppedContainer cid = containerDesc cid $ property desc $
  where
 	desc = "stopped"
 	cleanup = do
-		nukeFile $ namedPipe cid
 		nukeFile $ identFile cid
 		removeDirectoryRecursive $ shimdir cid
 		clearProvisionedFlag cid
@ -496,6 +500,9 @@ runContainer :: Image -> [RunParam] -> [String] -> IO Bool
 runContainer image ps cmd = boolSystem dockercmd $ map Param $
 	"run" : (ps ++ image : cmd)

+inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
+inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
+
 commitContainer :: ContainerId -> IO (Maybe Image)
 commitContainer cid = catchMaybeIO $
 	takeWhile (/= '\n') 
@ -521,13 +528,13 @@ listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]

 runProp :: String -> RunParam -> Property
 runProp field val = pureInfoProperty (param) $ dockerInfo $
-	mempty { _dockerRunParams = [\_ -> "--"++param] }
+	mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
  where
 	param = field++"="++val

 genProp :: String -> (HostName -> RunParam) -> Property
 genProp field mkval = pureInfoProperty field $ dockerInfo $
-	mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }
+	mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }

 dockerInfo :: DockerInfo -> Info
 dockerInfo i = mempty { _dockerinfo = i }
@ -538,10 +545,6 @@ dockerInfo i = mempty { _dockerinfo = i }
 propellorIdent :: FilePath
 propellorIdent = "/.propellor-ident"

-- | Named pipe used for communication with the container.
-namedPipe :: ContainerId -> FilePath
-namedPipe cid = "docker" </> fromContainerId cid
-
 provisionedFlag :: ContainerId -> FilePath
 provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"

@ -556,6 +559,9 @@ setProvisionedFlag cid = do
 checkProvisionedFlag :: ContainerId -> IO Bool
 checkProvisionedFlag = doesFileExist . provisionedFlag

+provisioningLock :: ContainerId -> FilePath
+provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock"
+
 shimdir :: ContainerId -> FilePath
 shimdir cid = "docker" </> fromContainerId cid ++ ".shim"

--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@ -7,14 +7,14 @@ import Data.List

 -- | Ensures that the hostname is set using best practices.
 --
-- Configures /etc/hostname and the current hostname.
+-- Configures `/etc/hostname` and the current hostname.
 --
-- Configures /etc/mailname with the domain part of the hostname.
+-- Configures `/etc/mailname` with the domain part of the hostname.
 --
-- /etc/hosts is also configured, with an entry for 127.0.1.1, which is
+-- `/etc/hosts` is also configured, with an entry for 127.0.1.1, which is
 -- standard at least on Debian to set the FDQN.
 --
-- Also, the /etc/hosts 127.0.0.1 line is set to localhost. Putting any
+-- Also, the `/etc/hosts` 127.0.0.1 line is set to localhost. Putting any
 -- other hostnames there is not best practices and can lead to annoying
 -- messages from eg, apache.
 sane :: Property
@ -44,7 +44,7 @@ setTo hn = combineProperties desc go
 		(ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls
 	hasip ip l = headMaybe (words l) == Just ip

-- | Makes /etc/resolv.conf contain search and domain lines for 
+-- | Makes `/etc/resolv.conf` contain search and domain lines for 
 -- the domain that the hostname is in.
 searchDomain :: Property
 searchDomain = property desc (ensureProperty . go =<< asks hostName)
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@ -88,7 +88,7 @@ cabalDeps = flagFile go cabalupdated
 		go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
 		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"

-standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host
+standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container
 standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
 	(dockerImage $ System (Debian Testing) arch)
 	& os (System (Debian Testing) arch)
@ -101,14 +101,14 @@ standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.conta
 	& autobuilder arch (show buildminute ++ " * * * *") timeout
 	& Docker.tweaked

-androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host
+androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
 androidAutoBuilderContainer dockerImage crontimes timeout =
 	androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
 		& Apt.unattendedUpgrades
 		& autobuilder "android" crontimes timeout

 -- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host
+androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container
 androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
 	(dockerImage osver)
 	& os osver
@ -137,7 +137,7 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
 -- armel builder has a companion container using amd64 that
 -- runs the build first to get TH splices. They need
 -- to have the same versions of all haskell libraries installed.
-armelCompanionContainer :: (System -> Docker.Image) -> Host
+armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container
 armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
 	(dockerImage $ System (Debian Unstable) "amd64")
 	& os (System (Debian Testing) "amd64")
@ -156,7 +156,7 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-
 	& Ssh.authorizedKeys builduser (Context "armel-git-annex-builder")
 	& Docker.tweaked

-armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host
+armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
 armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"
 	(dockerImage $ System (Debian Unstable) "armel")
 	& os (System (Debian Testing) "armel")
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@ -1,4 +1,4 @@
-- | Specific configuation for Joey Hess's sites. Probably not useful to
+-- | Specific configuration for Joey Hess's sites. Probably not useful to
 -- others except as an example.

 module Propellor.Property.SiteSpecific.JoeySites where
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@ -2,6 +2,10 @@
 -- a local and remote propellor. It's sent over a ssh channel, and lines of
 -- the protocol can be interspersed with other, non-protocol lines
 -- that should be passed through to be displayed.
+--
+-- Avoid making backwards-incompatible changes to this protocol,
+-- since propellor needs to use this protocol to update itself to new
+-- versions speaking newer versions of the protocol.

 module Propellor.Protocol where

--- a/src/Propellor/Server.hs
+++ b/src/Propellor/Server.hs
@ -0,0 +1,139 @@
+module Propellor.Server (
+	update,
+	updateServer,
+	gitPushHelper
+) where
+
+import Data.List
+import System.Exit
+import System.PosixCompat
+import System.Posix.IO
+import Control.Concurrent.Async
+import qualified Data.ByteString as B
+
+import Propellor
+import Propellor.Protocol
+import Propellor.PrivData.Paths
+import Propellor.Git
+import Propellor.Ssh
+import Utility.FileMode
+import Utility.SafeCommand
+
+-- Update the privdata, repo url, and git repo over the ssh
+-- connection, talking to the user's local propellor instance which is
+-- running the updateServer
+update :: IO ()
+update = do
+	req NeedRepoUrl repoUrlMarker setRepoUrl
+	makePrivDataDir
+	req NeedPrivData privDataMarker $
+		writeFileProtected privDataLocal
+	req NeedGitPush gitPushMarker $ \_ -> do
+		hin <- dup stdInput
+		hout <- dup stdOutput
+		hClose stdin
+		hClose stdout
+		unlessM (boolSystem "git" (pullparams hin hout)) $
+			errorMessage "git pull from client failed"
+  where
+	pullparams hin hout =
+		[ Param "pull"
+		, Param "--progress"
+		, Param "--upload-pack"
+		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+		, Param "."
+		]
+
+-- The connect action should ssh to the remote host and run the provided
+-- calback action.
+updateServer :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
+updateServer hn hst connect = connect go
+  where
+	go (toh, fromh) = do
+		let loop = go (toh, fromh)
+		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
+		case v of
+			(Just NeedRepoUrl) -> do
+				sendRepoUrl toh
+				loop
+			(Just NeedPrivData) -> do
+				sendPrivData hn hst toh
+				loop
+			(Just NeedGitPush) -> do
+				sendGitUpdate hn fromh toh
+				-- no more protocol possible after git push
+				hClose fromh
+				hClose toh
+			(Just NeedGitClone) -> do
+				hClose toh
+				hClose fromh
+				sendGitClone hn
+				updateServer hn hst connect
+			Nothing -> return ()
+
+sendRepoUrl :: Handle -> IO ()
+sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
+
+sendPrivData :: HostName -> Host -> Handle -> IO ()
+sendPrivData hn hst toh = do
+	privdata <- show . filterPrivData hst <$> decryptPrivData
+	void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
+		sendMarked toh privDataMarker privdata
+		return True
+
+sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
+sendGitUpdate hn fromh toh =
+	void $ actionMessage ("Sending git update to " ++ hn) $ do
+		sendMarked toh gitPushMarker ""
+		(Nothing, Nothing, Nothing, h) <- createProcess p
+		(==) ExitSuccess <$> waitForProcess h
+  where
+	p = (proc "git" ["upload-pack", "."])
+		{ std_in = UseHandle fromh
+		, std_out = UseHandle toh
+		}
+
+-- Initial git clone, used for bootstrapping.
+sendGitClone :: HostName -> IO ()
+sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
+	branch <- getCurrentBranch
+	cacheparams <- sshCachingParams hn
+	withTmpFile "propellor.git" $ \tmp _ -> allM id
+		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
+		]
+  where
+	remotebundle = "/usr/local/propellor.git"
+	unpackcmd branch = shellWrap $ intercalate " && "
+		[ "git clone " ++ remotebundle ++ " " ++ localdir
+		, "cd " ++ localdir
+		, "git checkout -b " ++ branch
+		, "git remote rm origin"
+		, "rm -f " ++ remotebundle
+		]
+
+-- Shim for git push over the propellor ssh channel.
+-- Reads from stdin and sends it to hout;
+-- reads from hin and sends it to stdout.
+gitPushHelper :: Fd -> Fd -> IO ()
+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
+  where
+	fromstdin = do
+		h <- fdToHandle hout
+		connect stdin h
+	tostdout = do
+		h <- fdToHandle hin
+		connect h stdout
+	connect fromh toh = do
+		hSetBinaryMode fromh True
+		hSetBinaryMode toh True
+		b <- B.hGetSome fromh 40960
+		if B.null b
+			then do
+				hClose fromh
+				hClose toh
+			else do
+				B.hPut toh b
+				hFlush toh
+				connect fromh toh
--- a/src/Propellor/SimpleSh.hs
+++ b/src/Propellor/SimpleSh.hs
@ -1,101 +0,0 @@
-- | Simple server, using a named pipe. Client connects, sends a command,
-- and gets back all the output from the command, in a stream.
--
-- This is useful for eg, docker.
-
-module Propellor.SimpleSh where
-
-import Network.Socket
-import Control.Concurrent
-import Control.Concurrent.Async
-import System.Process (std_in, std_out, std_err)
-
-import Propellor
-import Utility.FileMode
-import Utility.ThreadScheduler
-
-data Cmd = Cmd String [String]
-	deriving (Read, Show)
-
-data Resp = StdoutLine String | StderrLine String | Done
-	deriving (Read, Show)
-
-simpleSh :: FilePath -> IO ()
-simpleSh namedpipe = do
-	nukeFile namedpipe
-	let dir = takeDirectory namedpipe
-	createDirectoryIfMissing True dir
-	modifyFileMode dir (removeModes otherGroupModes)
-	s <- socket AF_UNIX Stream defaultProtocol
-	bindSocket s (SockAddrUnix namedpipe)
-	listen s 2
-	forever $ do
-		(client, _addr) <- accept s
-		forkIO $ do
-			h <- socketToHandle client ReadWriteMode
-			maybe noop (run h) . readish =<< hGetLine h
-  where
-	run h (Cmd cmd params) = do
-		chan <- newChan
-		let runwriter = do
-			v <- readChan chan
-			hPutStrLn h (show v)
-			hFlush h
-			case v of
-				Done -> noop
-				_ -> runwriter
-		writer <- async runwriter
-
-		flip catchIO (\_e -> writeChan chan Done) $ do
-			let p = (proc cmd params)
-				{ std_in = Inherit
-				, std_out = CreatePipe
-				, std_err = CreatePipe
-				}
-			(Nothing, Just outh, Just errh, pid) <- createProcess p
-
-			let mkreader t from = maybe noop (const $ mkreader t from) 
-				=<< catchMaybeIO (writeChan chan . t =<< hGetLine from)
-			void $ concurrently
-				(mkreader StdoutLine outh)
-				(mkreader StderrLine errh)
-		
-			void $ tryIO $ waitForProcess pid
-
-			writeChan chan Done
-
-			hClose outh
-			hClose errh
-
-		wait writer
-		hClose h
-
-simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
-simpleShClient namedpipe cmd params handler = do
-	s <- socket AF_UNIX Stream defaultProtocol
-	connect s (SockAddrUnix namedpipe)
-	h <- socketToHandle s ReadWriteMode
-	hPutStrLn h $ show $ Cmd cmd params
-	hFlush h
-	resps <- catMaybes . map readish . lines <$> hGetContents h
-	v <- hClose h `after` handler resps
-	return v
-
-simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
-simpleShClientRetry retries namedpipe cmd params handler = go retries
-  where
-	run = simpleShClient namedpipe cmd params handler
-	go n
-		| n < 1 = run
-		| otherwise = do
-			v <- tryIO run
-			case v of
-				Right r -> return r
-				Left e -> do
-					debug ["simplesh connection retry", show e]
-					threadDelaySeconds (Seconds 1)
-					go (n - 1)
-
-getStdout :: Resp -> Maybe String
-getStdout (StdoutLine s) = Just s
-getStdout _ = Nothing
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@ -3,7 +3,7 @@

 module Propellor.Types
 	( Host(..)
-	, Info
+	, Info(..)
 	, getInfo
 	, Propellor(..)
 	, Property(..)
@ -21,6 +21,10 @@ module Propellor.Types
 	, Context(..)
 	, anyContext
 	, SshKeyType(..)
+	, Val(..)
+	, fromVal
+	, DockerInfo(..)
+	, DockerRunParam(..)
 	, module Propellor.Types.OS
 	, module Propellor.Types.Dns
 	) where
@ -31,8 +35,10 @@ import System.Console.ANSI
 import System.Posix.Types
 import "mtl" Control.Monad.Reader
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Propellor.Types.Dns as Dns

-import Propellor.Types.Info
 import Propellor.Types.OS
 import Propellor.Types.Dns
 import Propellor.Types.PrivData
@ -145,8 +151,69 @@ data CmdLine
 	| ListFields
 	| AddKey String
 	| Continue CmdLine
-	| Chain HostName Bool
 	| Update HostName
-	| Docker HostName
+	| DockerInit HostName
+	| DockerChain HostName String
 	| GitPush Fd Fd
 	deriving (Read, Show, Eq)
+
+-- | Information about a host.
+data Info = Info
+	{ _os :: Val System
+	, _privDataFields :: S.Set (PrivDataField, Context)
+	, _sshPubKey :: Val String
+	, _aliases :: S.Set HostName
+	, _dns :: S.Set Dns.Record
+	, _namedconf :: Dns.NamedConfMap
+	, _dockerinfo :: DockerInfo
+	}
+	deriving (Eq, Show)
+
+instance Monoid Info where
+	mempty = Info mempty mempty mempty mempty mempty mempty mempty
+	mappend old new = Info
+		{ _os = _os old <> _os new
+		, _privDataFields = _privDataFields old <> _privDataFields new
+		, _sshPubKey = _sshPubKey old <> _sshPubKey new
+		, _aliases = _aliases old <> _aliases new
+		, _dns = _dns old <> _dns new
+		, _namedconf = _namedconf old <> _namedconf new
+		, _dockerinfo = _dockerinfo old <> _dockerinfo 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 DockerInfo = DockerInfo
+	{ _dockerRunParams :: [DockerRunParam]
+	, _dockerContainers :: M.Map String Host
+	}
+	deriving (Show)
+
+instance Monoid DockerInfo where
+	mempty = DockerInfo mempty mempty
+	mappend old new = DockerInfo
+		{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
+		, _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new)
+		}
+
+instance Eq DockerInfo where
+	x == y = and
+		[ let simpl v = map (\(DockerRunParam a) -> a "") (_dockerRunParams v)
+		  in simpl x == simpl y
+		]
+
+newtype DockerRunParam = DockerRunParam (HostName -> String)
+
+instance Show DockerRunParam where
+	show (DockerRunParam a) = a ""
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@ -1,70 +0,0 @@
-module Propellor.Types.Info where
-
-import Propellor.Types.OS
-import Propellor.Types.PrivData
-import qualified Propellor.Types.Dns as Dns
-
-import qualified Data.Set as S
-import Data.Monoid
-
-- | Information about a host.
-data Info = Info
-	{ _os :: Val System
-	, _privDataFields :: S.Set (PrivDataField, Context)
-	, _sshPubKey :: Val String
-	, _aliases :: S.Set HostName
-	, _dns :: S.Set Dns.Record
-	, _namedconf :: Dns.NamedConfMap
-	, _dockerinfo :: DockerInfo
-	}
-	deriving (Eq, Show)
-
-instance Monoid Info where
-	mempty = Info mempty mempty mempty mempty mempty mempty mempty
-	mappend old new = Info
-		{ _os = _os old <> _os new
-		, _privDataFields = _privDataFields old <> _privDataFields new
-		, _sshPubKey = _sshPubKey old <> _sshPubKey new
-		, _aliases = _aliases old <> _aliases new
-		, _dns = _dns old <> _dns new
-		, _namedconf = _namedconf old <> _namedconf new
-		, _dockerinfo = _dockerinfo old <> _dockerinfo 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 DockerInfo = DockerInfo
-	{ _dockerImage :: Val String
-	, _dockerRunParams :: [HostName -> String]
-	}
-
-instance Eq DockerInfo where
-	x == y = and
-		[ _dockerImage x == _dockerImage y
-		, let simpl v = map (\a -> a "") (_dockerRunParams v)
-		  in simpl x == simpl y
-		]
-
-instance Monoid DockerInfo where
-	mempty = DockerInfo mempty mempty
-	mappend old new = DockerInfo
-		{ _dockerImage = _dockerImage old <> _dockerImage new
-		, _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
-		}
-
-instance Show DockerInfo where
-	show a = unlines
-		[ "docker image " ++ show (_dockerImage a)
-		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
-		]
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@ -10,9 +10,10 @@

 module Utility.Process (
 	module X,
-	CreateProcess,
+	CreateProcess(..),
 	StdHandle(..),
 	readProcess,
+	readProcess',
 	readProcessEnv,
 	writeReadProcessEnv,
 	forceSuccessProcess,
@ -31,6 +32,7 @@ module Utility.Process (
 	stdinHandle,
 	stdoutHandle,
 	stderrHandle,
+	bothHandles,
 	processHandle,
 	devNull,
 ) where
@ -65,17 +67,19 @@ readProcess :: FilePath	-> [String] -> IO String
 readProcess cmd args = readProcessEnv cmd args Nothing

 readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
-readProcessEnv cmd args environ =
-	withHandle StdoutHandle createProcessSuccess p $ \h -> do
-		output  <- hGetContentsStrict h
-		hClose h
-		return output
+readProcessEnv cmd args environ = readProcess' p
  where
 	p = (proc cmd args)
 		{ std_out = CreatePipe
 		, env = environ
 		}

+readProcess' :: CreateProcess -> IO String
+readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
+	output  <- hGetContentsStrict h
+	hClose h
+	return output
+
 {- Runs an action to write to a process on its stdin, 
 - returns its output, and also allows specifying the environment.
 -}
--- a/src/Utility/SafeCommand.hs
+++ b/src/Utility/SafeCommand.hs
@ -9,7 +9,6 @@ module Utility.SafeCommand where

 import System.Exit
 import Utility.Process
-import System.Process (env)
 import Data.String.Utils
 import Control.Applicative
 import System.FilePath