Merge branch 'joeyconfig'

Conflicts:
	Propellor/Property/Docker.hs

Propellor/CmdLine.hs

@@ -8,9 +8,12 @@ import System.Log.Formatter
 import System.Log.Handler (setFormatter, LogHandler)
 import System.Log.Handler.Simple
 import System.PosixCompat
+import Control.Exception (bracket)
+import System.Posix.IO
 
 import Propellor
 import qualified Propellor.Property.Docker as Docker
+import qualified Propellor.Property.Docker.Shim as DockerShim
 import Utility.FileMode
 import Utility.SafeCommand
 
@@ -53,6 +56,7 @@ processCmdLine = go =<< getArgs
 
 defaultMain :: [HostName -> Maybe [Property]] -> IO ()
 defaultMain getprops = do
+	DockerShim.cleanEnv
 	checkDebugMode
 	cmdline <- processCmdLine
 	debug ["command line: ", show cmdline]
@@ -69,14 +73,26 @@ defaultMain getprops = do
 	go True cmdline = updateFirst cmdline $ go False cmdline
 	go False (Spin host) = withprops host $ const $ spin host
 	go False (Run host) = ifM ((==) 0 <$> getRealUserID)
-		( withprops host ensureProperties
+		( onlyProcess $ withprops host ensureProperties
 		, go True (Spin host)
 		)
-	go False (Boot host) = withprops host $ boot
+	go False (Boot host) = onlyProcess $ withprops host $ boot
 
 	withprops host a = maybe (unknownhost host) a $
 		headMaybe $ catMaybes $ map (\get -> get host) getprops
 
+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"
+
 unknownhost :: HostName -> IO a
 unknownhost h = errorMessage $ unlines
 	[ "Unknown host: " ++ h

Propellor/Property/Docker.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, BangPatterns #-}
 
 -- | Docker support for propellor
 --
@@ -17,6 +17,7 @@ import Utility.Path
 
 import Control.Concurrent.Async
 import System.Posix.Directory
+import System.Posix.Process
 import Data.List
 import Data.List.Utils
 
@@ -166,7 +167,7 @@ volume = runProp "volume"
 -- | Mount a volume from the specified container into the current
 -- container.
 volumes_from :: ContainerName -> Containerized Property
-volumes_from cn = genProp "volumes-rom" $ \hn ->
+volumes_from cn = genProp "volumes-from" $ \hn ->
 	fromContainerId (ContainerId hn cn)
 
 -- | Work dir inside the container. 
@@ -241,24 +242,34 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 	l <- listContainers RunningContainers
 	if cid `elem` l
 		then do
+			-- Check if the ident has changed; if so the
+			-- parameters of the container differ and it must
+			-- be restarted.
 			runningident <- getrunningident
-			if (ident2id <$> runningident) == Just (ident2id ident)
+			if runningident == Just ident
 				then return NoChange
 				else do
 					void $ stopContainer cid
-					oldimage <- fromMaybe image <$> commitContainer cid
+					restartcontainer
-					void $ removeContainer cid
+		else ifM (elem cid <$> listContainers AllContainers)
-					go oldimage
+			( restartcontainer
-		else do
+			, go image
-			whenM (elem cid <$> listContainers AllContainers) $ do
+			)
-				void $ removeContainer cid
-			go image
   where
 	ident = ContainerIdent image hn cn runps
 
-	getrunningident = catchDefaultIO Nothing $
+	restartcontainer = do
-		simpleShClient (namedPipe cid) "cat" [propellorIdent] $
+		oldimage <- fromMaybe image <$> commitContainer cid
-			pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout
+		void $ removeContainer cid
+		go oldimage
+
+	getrunningident :: IO (Maybe ContainerIdent)
+	getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
+		let !v = extractident rs
+		return v
+
+	extractident :: [Resp] -> Maybe ContainerIdent
+	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
 
 	runps = getRunParams hn $ containerprops ++
 		-- expose propellor directory inside the container
@@ -280,6 +291,9 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 -- | Called when propellor is running inside a docker container.
 -- The string should be the container's ContainerId.
 --
+-- 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.
@@ -305,13 +319,17 @@ chain s = case toContainerId s of
 			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
 			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
 				warningMessage "Boot provision failed!"
-		void $ async $ simpleSh $ namedPipe cid
+		void $ async $ job reapzombies
-		forever $ do
+		void $ async $ job $ simpleSh $ namedPipe cid
-			void $ ifM (inPath "bash")
+		job $ do
+			void $ tryIO $ ifM (inPath "bash")
 				( boolSystem "bash" [Param "-l"]
 				, boolSystem "/bin/sh" []
 				)
 			putStrLn "Container is still running. Press ^P^Q to detach."
+  where
+	job = forever . void . tryIO
+	reapzombies = void $ getAnyProcessStatus True False
 
 -- | Once a container is running, propellor can be run inside
 -- it to provision it.
@@ -343,7 +361,7 @@ provisionContainer cid = containerDesc cid $ Property "provision" $ do
 			hPutStrLn stderr s
 			hFlush stderr
 			go Nothing rest
-		Done _ -> ret lastline
+		Done -> ret lastline
 	go lastline [] = ret lastline
 
 	ret lastline = return $ fromMaybe FailedChange $

Propellor/Property/Docker/Shim.hs

@@ -3,7 +3,7 @@
 --
 -- Note: This is currently Debian specific, due to glibcLibs.
 
-module Propellor.Property.Docker.Shim (setup, file) where
+module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where
 
 import Propellor
 import Utility.LinuxMkLibs
@@ -44,6 +44,9 @@ setup propellorbin dest = do
 	modifyFileMode shim (addModes executeModes)
 	return shim
 
+cleanEnv :: IO ()
+cleanEnv = void $ unsetEnv "GCONV_PATH"
+
 file :: FilePath -> FilePath -> FilePath
 file propellorbin dest = dest </> takeFileName propellorbin
 

Propellor/Property/SiteSpecific/GitAnnexBuilder.hs

@@ -9,8 +9,14 @@ import Propellor.Property.Cron (CronTimes)
 builduser :: UserName
 builduser = "builder"
 
+homedir :: FilePath
+homedir = "/home/builder"
+
+gitbuilderdir :: FilePath
+gitbuilderdir = homedir </> "gitbuilder"
+
 builddir :: FilePath
-builddir = "gitbuilder"
+builddir = gitbuilderdir </> "build"
 
 builder :: Architecture -> CronTimes -> Bool -> Property
 builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
@@ -20,26 +26,22 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
 		"liblockfile-simple-perl", "cabal-install", "vim", "less"]
 	, serviceRunning "cron" `requires` Apt.installed ["cron"]
 	, User.accountFor builduser
-	, check (lacksdir builddir) $ userScriptProperty builduser
+	, check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser
-		[ "git clone git://git.kitenet.net/gitannexbuilder " ++ builddir
+		[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
-		, "cd " ++ builddir
+		, "cd " ++ gitbuilderdir
 		, "git checkout " ++ arch
 		]
 		`describe` "gitbuilder setup"
-	, check (lacksdir $ builddir </> "build") $ userScriptProperty builduser
+	, check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
-		[ "cd " ++ builddir
+		[ "git clone git://git-annex.branchable.com/ " ++ builddir
-		, "git clone git://git-annex.branchable.com/ build"
 		]
-	, Property "git-annex source build deps installed" $ do
+	, "git-annex source build deps installed" ==> Apt.buildDepIn builddir
-		d <- homedir
+	, Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir "git pull ; ./autobuild"
-		ensureProperty $ Apt.buildDepIn (d </> builddir </> "build")
-	, Cron.niceJob "gitannexbuilder" crontimes builduser ("~/" ++ builddir) "git pull ; ./autobuild"
 	-- The builduser account does not have a password set,
 	-- instead use the password privdata to hold the rsync server
 	-- password used to upload the built image.
 	, Property "rsync password" $ do
-		d <- homedir
+		let f = homedir </> "rsyncpassword"
-		let f = d </> "rsyncpassword"
 		if rsyncupload 
 			then withPrivData (Password builduser) $ \p -> do
 				oldp <- catchDefaultIO "" $ readFileStrict f
@@ -52,8 +54,3 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
 					, makeChange $ writeFile f "no password configured"
 					)
 	]
-  where
-  	homedir = fromMaybe ("/home/" ++ builduser) <$> User.homedir builduser
-	lacksdir d = do
-		h <- homedir
-		not <$> doesDirectoryExist (h </> d)

Propellor/SimpleSh.hs

@@ -9,7 +9,6 @@ import Network.Socket
 import Control.Concurrent.Chan
 import Control.Concurrent.Async
 import System.Process (std_in, std_out, std_err)
-import System.Exit
 
 import Propellor
 import Utility.FileMode
@@ -18,7 +17,7 @@ import Utility.ThreadScheduler
 data Cmd = Cmd String [String]
 	deriving (Read, Show)
 
-data Resp = StdoutLine String | StderrLine String | Done ExitCode
+data Resp = StdoutLine String | StderrLine String | Done
 	deriving (Read, Show)
 
 simpleSh :: FilePath -> IO ()
@@ -49,7 +48,7 @@ simpleSh namedpipe = do
 			v <- readChan chan
 			hPutStrLn h (show v)
 			case v of
-				Done _ -> noop
+				Done -> noop
 				_ -> runwriter
 		writer <- async runwriter
 
@@ -59,7 +58,9 @@ simpleSh namedpipe = do
 			(mkreader StdoutLine outh)
 			(mkreader StderrLine errh)
 		
-		writeChan chan . Done =<< waitForProcess pid
+		void $ tryIO $ waitForProcess pid
+
+		writeChan chan Done
 
 		wait writer
 

config-joey.hs

@@ -36,7 +36,6 @@ host hostname@"clam.kitenet.net" = standardSystem Unstable $ props
 	& Tor.isBridge
 	& JoeySites.oldUseNetshellBox
 	& Docker.configured
-	! Docker.docked container hostname "amd64-git-annex-builder"
 	& Docker.garbageCollected
 -- Orca is the main git-annex build box.
 host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
@@ -46,6 +45,8 @@ host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
 	& Apt.buildDep ["git-annex"]
 	& Docker.docked container hostname "amd64-git-annex-builder"
 	& Docker.docked container hostname "i386-git-annex-builder"
+	& Docker.docked container hostname "armel-git-annex-builder-companion"
+	& Docker.docked container hostname "armel-git-annex-builder"
 	& Docker.garbageCollected
 -- My laptop
 host _hostname@"darkstar.kitenet.net" = Just $ props
@@ -67,11 +68,29 @@ container _host name
 			& serviceRunning "apache2"
 				`requires` Apt.installed ["apache2"]
 		]
+	
+	-- armel builder has a companion container that run amd64 and
+	-- runs the build first to get TH splices. They share a home
+	-- directory, and need to have the same versions of all haskell
+	-- libraries installed.
+	| name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom
+		(image $ System (Debian Unstable) "amd64")
+		[ Docker.volume GitAnnexBuilder.homedir
+		]
+	| name == "armel-git-annex-builder" = Just $ Docker.containerFrom
+		(image $ System (Debian Unstable) "armel")
+		[ Docker.link (name ++ "-companion") "companion"
+		, Docker.volumes_from (name ++ "-companion")
+		, Docker.inside $ props
+--			& GitAnnexBuilder.builder "armel" "15 * * * *" True
+		]
+	
 	| "-git-annex-builder" `isSuffixOf` name =
 		let arch = takeWhile (/= '-') name
 		in Just $ Docker.containerFrom
 			(image $ System (Debian Unstable) arch)
 			[ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" True ]
+	
 	| otherwise = Nothing
 
 -- | Docker images I prefer to use.

debian/changelog

@@ -1,3 +1,12 @@
+propellor (0.2.3) UNRELEASED; urgency=medium
+
+  * docker: Fix laziness bug that caused running containers to be
+    unnecessarily stopped and committed.
+  * Add locking so only one propellor can run at a time on a host.
+  * docker: When running as effective init inside container, wait on zombies.
+
+ -- Joey Hess <joeyh@debian.org>  Fri, 04 Apr 2014 15:58:03 -0400
+
 propellor (0.2.2) unstable; urgency=medium
 
   * Now supports provisioning docker containers with architecture/libraries