summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Docker.hs
diff options
context:
space:
mode:
authorJoey Hess2014-11-19 00:30:06 -0400
committerJoey Hess2014-11-19 00:30:06 -0400
commit325fe4037bf5b027191ab88dd90f05d81f61fd0a (patch)
tree0591f4233b1dbabd38582e7a04717c22ab44fba9 /src/Propellor/Property/Docker.hs
parent111e08e156df5a41d61c370ebd077174e35f5d9b (diff)
propellor spin
Diffstat (limited to 'src/Propellor/Property/Docker.hs')
-rw-r--r--src/Propellor/Property/Docker.hs42
1 files changed, 19 insertions, 23 deletions
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 491955dd..2b4faf7b 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/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 <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
+ r <- inContainer cid
+ [ 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
- 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
-
- ret lastline = pure $ fromMaybe FailedChange $ readish =<< 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
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')