propellor spin

config-joey.hs

@@ -53,6 +53,7 @@ darkstar = host "darkstar.kitenet.net"
 	& Apt.buildDep ["git-annex"] `period` Daily
 	& Docker.configured
 	! Docker.docked hosts "android-git-annex"
+	& Docker.docked hosts "simple-debian"
 
 clam :: Host
 clam = standardSystem "clam.kitenet.net" Unstable "amd64"
@@ -309,6 +310,9 @@ containers =
 		& Docker.publish "4200:4200"
 		& JoeySites.oldUseNetShellBox
 
+	, Docker.container "simple-debian" "debian"
+		& "/hello" `File.containsLine` "hello"
+
 	-- git-annex autobuilder containers
 	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h"
 	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h"

src/Propellor/CmdLine.hs

@@ -86,8 +86,7 @@ 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
+	go _ (Chain hn) = withhost hn $ \h -> do
-		when isconsole forceConsole
 		r <- runPropellor h $ ensureProperties $ hostProperties h
 		putStrLn $ "\n" ++ show r
 	go _ (Docker hn) = Docker.chain hn

src/Propellor/Property/Docker.hs

@@ -416,7 +416,7 @@ chain s = case toContainerId s of
 		-- 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 $ Chain (containerHostName cid)]) $
 				warningMessage "Boot provision failed!"
 		void $ async $ job reapzombies
 		void $ async $ job $ simpleSh $ namedPipe cid
@@ -432,36 +432,28 @@ 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 $ Chain (containerHostName cid)]
 	msgh <- mkMessageHandle
-	let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)]
+	r <- inContainer cid
-	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
+		[ if isConsole msgh then "-it" else "-i" ]
+		(shim : params)
+		(processoutput Nothing)
 	when (r /= FailedChange) $
 		setProvisionedFlag cid 
 	return r
   where
-	go lastline (v:rest) = case v of
+	processoutput lastline h = do
-		StdoutLine s -> do
+		v <- catchMaybeIO (hGetLine h)
+		case v of
+			Nothing -> pure $ fromMaybe FailedChange $
+				readish =<< lastline
+			Just s -> do
 				maybe noop putStrLn lastline
 				hFlush stdout
-			go (Just s) rest
+				processoutput (Just s) h
-		StderrLine s -> do
-			maybe noop putStrLn lastline
-			hFlush stdout
-			hPutStrLn stderr s
-			hFlush stderr
-			go Nothing rest
-		Done -> ret lastline
-	go lastline [] = ret lastline
-
-	ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
 
 stopContainer :: ContainerId -> IO Bool
 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
@@ -496,6 +488,10 @@ runContainer :: Image -> [RunParam] -> [String] -> IO Bool
 runContainer image ps cmd = boolSystem dockercmd $ map Param $
 	"run" : (ps ++ image : cmd)
 
+inContainer :: ContainerId -> [String] -> [String] -> (Handle -> IO a) -> IO a
+inContainer cid ps cmd = withHandle StdinHandle createProcessSuccess
+	(proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd))
+
 commitContainer :: ContainerId -> IO (Maybe Image)
 commitContainer cid = catchMaybeIO $
 	takeWhile (/= '\n') 

src/Propellor/Types.hs

@@ -145,7 +145,7 @@ data CmdLine
 	| ListFields
 	| AddKey String
 	| Continue CmdLine
-	| Chain HostName Bool
+	| Chain HostName
 	| Update HostName
 	| Docker HostName
 	| GitPush Fd Fd