Merge branch 'joeyconfig'

6 files changed, 368 insertions, 110 deletions

diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
new file mode 100644
index 00000000..4e7bc740
--- /dev/null
+++ 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
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 135c765d..f351804c 100644
--- 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
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 491955dd..676d323a 100644
--- 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
+
+toChain :: ContainerId -> CmdLine
+toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
 
-	ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
+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"
 
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index c489e2fb..4a5e77d3 100644
--- 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)
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 901eba2e..0208dea6 100644
--- 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")
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 4a95067f..ad1c661a 100644
--- 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