prevent multiple concurrent provisioning inside docker container

Lock a lock file while provisioning inside, otherwise propellor could be
running to init the container when the system has just booted, or the
container was just started from being stopped, and at the same time,
propellor run outside the container chains into it to provision.

Previously, simplesh prevented this in a different way.

src/Propellor/CmdLine.hs

@@ -7,8 +7,6 @@ import System.Environment (getArgs)
 import Data.List
 import System.Exit
 import System.PosixCompat
-import Control.Exception (bracket)
-import System.Posix.IO
 
 import Propellor
 import Propellor.Protocol
@@ -86,10 +84,8 @@ defaultMain hostlist = do
 	go _ (Edit field context) = editPrivData field context
 	go _ ListFields = listPrivDataFields hostlist
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain hn) = withhost hn $ \h -> do
-		r <- runPropellor h $ ensureProperties $ hostProperties h
-		putStrLn $ "\n" ++ show r
-	go _ (Docker hn) = Docker.chain hn
+	go _ (DockerChain hn s) = withhost hn $ Docker.chain s
+	go _ (DockerInit hn) = Docker.init hn
 	go _ (GitPush fin fout) = gitPushHelper fin fout
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
@@ -97,27 +93,17 @@ defaultMain hostlist = do
 	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
+		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

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

src/Propellor/Property/Docker.hs

@@ -33,10 +33,11 @@ module Propellor.Property.Docker (
 	restartOnFailure,
 	restartNever,
 	-- * Internal use
+	init,
 	chain,
 ) where
 
-import Propellor
+import Propellor hiding (init)
 import Propellor.Types.Info
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
@@ -48,7 +49,8 @@ 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
 
@@ -391,7 +393,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.
@@ -406,20 +408,20 @@ 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
 		whenM (checkProvisionedFlag cid) $ do
 			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
-			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid)]) $
+			unlessM (boolSystem shim [Param "--continue", Param $ show $ DockerChain (containerHostName cid) (fromContainerId cid)]) $
 				warningMessage "Boot provision failed!"
 		void $ async $ job reapzombies
 		job $ do
@@ -437,7 +439,7 @@ chain s = case toContainerId s of
 provisionContainer :: ContainerId -> Property
 provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
-	let params = ["--continue", show $ Chain (containerHostName cid)]
+	let params = ["--continue", show $ DockerChain (containerHostName cid) (fromContainerId cid)]
 	msgh <- mkMessageHandle
 	let p = inContainerProcess cid
 		[ if isConsole msgh then "-it" else "-i" ]
@@ -458,6 +460,13 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d
 				hFlush stdout
 				processoutput (Just s) h
 
+chain :: String -> Host -> IO ()
+chain s h = case toContainerId s of
+	Just cid -> onlyProcess (provisioningLock cid) $ do
+		r <- runPropellor h $ ensureProperties $ hostProperties h
+		putStrLn $ "\n" ++ show r
+	Nothing -> error "bad container id"
+
 stopContainer :: ContainerId -> IO Bool
 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
 
@@ -549,6 +558,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"
 

src/Propellor/Types.hs

@@ -145,8 +145,8 @@ data CmdLine
 	| ListFields
 	| AddKey String
 	| Continue CmdLine
-	| Chain HostName
 	| Update HostName
-	| Docker HostName
+	| DockerInit HostName
+	| DockerChain HostName String
 	| GitPush Fd Fd
 	deriving (Read, Show, Eq)