summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Propellor/CmdLine.hs3
-rw-r--r--Propellor/Property/Docker.hs158
-rw-r--r--Propellor/SimpleSh.hs5
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