From 325fe4037bf5b027191ab88dd90f05d81f61fd0a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 00:30:06 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 3 +-- src/Propellor/Property/Docker.hs | 42 ++++++++++++++++++---------------------- src/Propellor/Types.hs | 2 +- 3 files changed, 21 insertions(+), 26 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 9006d903..e41ab39d 100644 --- a/src/Propellor/CmdLine.hs +++ b/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 - when isconsole forceConsole + go _ (Chain hn) = withhost hn $ \h -> do r <- runPropellor h $ ensureProperties $ hostProperties h putStrLn $ "\n" ++ show r go _ (Docker hn) = Docker.chain hn 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') diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index a1d25b4f..00da7495 100644 --- a/src/Propellor/Types.hs +++ b/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 -- cgit v1.2.3