From bf4ba055287f46d6e125d8fd7870dd981d224fc8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Apr 2014 03:48:45 -0400 Subject: docker support is working in theory (but untested) --- Propellor/CmdLine.hs | 3 + Propellor/Property/Docker.hs | 158 ++++++++++++++++++++++++------------------- Propellor/SimpleSh.hs | 5 ++ 3 files changed, 98 insertions(+), 68 deletions(-) diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 05df86bf..62f86e63 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -17,6 +17,7 @@ data CmdLine | AddKey String | Continue CmdLine | SimpleSh FilePath + | Chain HostName deriving (Read, Show, Eq) usage :: IO a @@ -45,6 +46,7 @@ processCmdLine = go =<< getArgs Just cmdline -> return $ Continue cmdline Nothing -> errorMessage "--continue serialization failure" go ("--simplesh":f:[]) = return $ SimpleSh f + go ("--chain":h:[]) = return $ Chain h go (h:[]) = return $ Run h go [] = do s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] @@ -60,6 +62,7 @@ defaultMain getprops = go True =<< processCmdLine go _ (Set host field) = setPrivData host field go _ (AddKey keyid) = addKey keyid go _ (SimpleSh f) = simpleSh f + go _ (Chain host) = withprops host $ print <=< ensureProperties' go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline go False (Spin host) = withprops host $ const $ spin host diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index 1f991709..450f397b 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -4,6 +4,7 @@ module Propellor.Property.Docker where import Propellor import Propellor.CmdLine +import Propellor.SimpleSh import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import Utility.SafeCommand @@ -40,6 +41,8 @@ fromContainerized l = map get l -- | A docker image, that can be used to run a container. type Image = String +-- | A short descriptive name for a container. +-- Should not contain whitespace or other unusual characters. type ContainerName = String -- | A container is identified by its name, and the host @@ -86,56 +89,83 @@ hasContainer hn cn findcontainer = warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid return FailedChange Just (Container image containerprops) -> - running image containerprops + Property desc (provisionContainer cid) + `requires` + Property desc (ensureContainer cid image containerprops) where cid = ContainerId hn cn desc = "docker container " ++ fromContainerId cid - -- Start the container, if it's not already running. - running image containerprops = Property desc $ do - let runps = getRunParams $ containerprops ++ - -- expose propellor directory inside the container - [ volume (localdir++":"++localdir) - -- name the container in a predictable way so we - -- and the user can easily find it later - , name (fromContainerId cid) - -- cd to propellor directory - , workdir localdir - ] - let ident = ContainerIdent image cid runps - let runit img = ifM (runContainer cid img runps ident) - ( do - r <- runinside - return $ MadeChange <> r - , return FailedChange - ) - l <- listRunningContainers - if cid `elem` l - then do - runningident <- readish <$> readContainerCommand cid "cat" ["/.propeller-ident"] - if runningident == Just ident - then runinside - else do - void $ stopContainer cid - oldimage <- fromMaybe image <$> commitContainer cid - removeContainer cid - runit oldimage - else do - removeContainer cid - runit image - - -- Use propellor binary exposed inside the container - -- (assumes libc compatablity), and run it, passing it the - -- container@hostname so it knows what to do. - -- Read its Result code and propigate - runinside :: IO Result - runinside = fromMaybe FailedChange . readish - <$> readContainerCommand cid "./propellor" [show params] - where - -- Using Continue avoids auto-update of the binary inside - -- the container. - params = Continue $ Run $ fromContainerId cid +ensureContainer :: ContainerId -> Image -> [Containerized Property] -> IO Result +ensureContainer cid image containerprops = do + l <- listRunningContainers + if cid `elem` l + then do + runningident <- getrunningident + if runningident == Just ident + then return NoChange + else do + void $ stopContainer cid + oldimage <- fromMaybe image <$> commitContainer cid + removeContainer cid + go oldimage + else do + removeContainer cid + go image + where + ident = ContainerIdent image cid runps + + -- Start the simplesh server that will be used by propellor + -- to run commands in the container. An interactive shell + -- is also started, so the user can attach and use it if desired. + startsimplesh = "sh -c './propellor --simplesh " ++ namedPipe cid ++ " & ; bash -l'" + + getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ + pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout + setrunningident = simpleShClient (namedPipe cid) "sh" + ["-c", "echo '" ++ show ident ++ "' > " ++ propellorIdent] + (const noop) + + runps = getRunParams $ containerprops ++ + -- expose propellor directory inside the container + [ volume (localdir++":"++localdir) + -- name the container in a predictable way so we + -- and the user can easily find it later + , name (fromContainerId cid) + -- cd to propellor directory + , workdir localdir + ] + + go img = ifM (runContainer img (runps ++ ["-d", "-t"]) startsimplesh) + ( do + setrunningident + return MadeChange + , return FailedChange + ) + +provisionContainer :: ContainerId -> IO Result +provisionContainer cid = do + simpleShClient (namedPipe cid) "./propellor" [show params] (go Nothing) + where + params = Chain $ fromContainerId cid + + 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 = return $ fromMaybe FailedChange $ + readish =<< lastline -- | Two containers with the same ContainerIdent were started from -- the same base image (possibly a different version though), and @@ -144,10 +174,14 @@ data ContainerIdent = ContainerIdent Image ContainerId [RunParam] deriving (Read, Show, Eq) -- | The ContainerIdent of a container is written to --- /.propeller-ident inside it. This can be checked to see if +-- /.propellor-ident inside it. This can be checked to see if -- the container has the same ident later. -propellerIdent :: FilePath -propellerIdent = "/.propeller-ident" +propellorIdent :: FilePath +propellorIdent = "/.propellor-ident" + +-- | Named pipe used for communication with the container. +namedPipe :: ContainerId -> FilePath +namedPipe cid = "docker/" ++ fromContainerId cid stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] @@ -156,32 +190,20 @@ removeContainer :: ContainerId -> IO () removeContainer cid = void $ boolSystem "sh" [Param "-c", Param $ dockercmd ++ " rm " ++ fromContainerId cid ] -runContainer :: ContainerId -> Image -> [RunParam] -> ContainerIdent -> IO Bool -runContainer cid image ps ident = do - ok <- boolSystem dockercmd undefined - when ok $ - void $ readContainerCommand cid "sh" - ["-c", "echo '" ++ show ident ++ "' > " ++ propellerIdent] - return ok - --- | Runs a command inside the container. -readContainerCommand :: ContainerId -> String -> [String] -> IO String -readContainerCommand cid command params = undefined +runContainer :: Image -> [RunParam] -> String -> IO Bool +runContainer image ps cmd = boolSystem dockercmd $ map Param $ + "run" : (ps ++ [image, cmd]) commitContainer :: ContainerId -> IO (Maybe Image) commitContainer cid = catchMaybeIO $ - readProcess dockercmd ["commit", fromContainerId cid] + takeWhile (/= '\n') + <$> readProcess dockercmd ["commit", fromContainerId cid] -- | Only lists propellor managed containers. listRunningContainers :: IO [ContainerId] -listRunningContainers = undefined -- docker.io ps - --- | Only lists propellor managed containers. -listContainers :: IO [ContainerId] -listContainers = undefined - -listImages :: IO [ContainerId] -listImages = undefined -- docker.io images --no-trunc +listRunningContainers = + catMaybes . map readish . catMaybes . map (lastMaybe . words) . lines + <$> readProcess dockercmd ["ps", "--no-trunc"] runProp :: String -> RunParam -> Containerized Property runProp field val = Containerized [param] (Property param (return NoChange)) diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs index 971fe502..25a154a9 100644 --- a/Propellor/SimpleSh.hs +++ b/Propellor/SimpleSh.hs @@ -22,6 +22,7 @@ data Resp = StdoutLine String | StderrLine String | Done ExitCode simpleSh :: FilePath -> IO () simpleSh namedpipe = do nukeFile namedpipe + createDirectoryIfMissing True (takeDirectory namedpipe) s <- socket AF_UNIX Stream defaultProtocol bind s (SockAddrUnix namedpipe) listen s 2 @@ -71,3 +72,7 @@ simpleShClient namedpipe cmd params handler = do hPutStrLn h $ show $ Cmd cmd params resps <- catMaybes . map readish . lines <$> hGetContents h hClose h `after` handler resps + +getStdout :: Resp -> Maybe String +getStdout (StdoutLine s) = Just s +getStdout _ = Nothing -- cgit v1.2.3