summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Propellor/CmdLine.hs20
-rw-r--r--Propellor/Property/Docker.hs52
-rw-r--r--Propellor/Property/Docker/Shim.hs5
-rw-r--r--Propellor/Property/SiteSpecific/GitAnnexBuilder.hs33
-rw-r--r--Propellor/SimpleSh.hs9
-rw-r--r--config-joey.hs21
-rw-r--r--debian/changelog9
7 files changed, 106 insertions, 43 deletions
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index a9c61993..5ea982c3 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -8,9 +8,12 @@ import System.Log.Formatter
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import System.PosixCompat
+import Control.Exception (bracket)
+import System.Posix.IO
import Propellor
import qualified Propellor.Property.Docker as Docker
+import qualified Propellor.Property.Docker.Shim as DockerShim
import Utility.FileMode
import Utility.SafeCommand
@@ -53,6 +56,7 @@ processCmdLine = go =<< getArgs
defaultMain :: [HostName -> Maybe [Property]] -> IO ()
defaultMain getprops = do
+ DockerShim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
@@ -69,14 +73,26 @@ defaultMain getprops = do
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin host) = withprops host $ const $ spin host
go False (Run host) = ifM ((==) 0 <$> getRealUserID)
- ( withprops host ensureProperties
+ ( onlyProcess $ withprops host ensureProperties
, go True (Spin host)
)
- go False (Boot host) = withprops host $ boot
+ go False (Boot host) = onlyProcess $ withprops host $ boot
withprops host a = maybe (unknownhost host) a $
headMaybe $ catMaybes $ map (\get -> get host) getprops
+onlyProcess :: IO a -> IO a
+onlyProcess a = bracket lock unlock (const a)
+ where
+ lock = do
+ l <- createFile lockfile stdFileMode
+ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+ `catchIO` const alreadyrunning
+ return l
+ unlock = closeFd
+ alreadyrunning = error "Propellor is already running on this host!"
+ lockfile = localdir </> ".lock"
+
unknownhost :: HostName -> IO a
unknownhost h = errorMessage $ unlines
[ "Unknown host: " ++ h
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index 573b4c62..b573e641 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, BangPatterns #-}
-- | Docker support for propellor
--
@@ -17,6 +17,7 @@ import Utility.Path
import Control.Concurrent.Async
import System.Posix.Directory
+import System.Posix.Process
import Data.List
import Data.List.Utils
@@ -166,7 +167,7 @@ volume = runProp "volume"
-- | Mount a volume from the specified container into the current
-- container.
volumes_from :: ContainerName -> Containerized Property
-volumes_from cn = genProp "volumes-rom" $ \hn ->
+volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
@@ -241,24 +242,34 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
l <- listContainers RunningContainers
if cid `elem` l
then do
+ -- Check if the ident has changed; if so the
+ -- parameters of the container differ and it must
+ -- be restarted.
runningident <- getrunningident
- if (ident2id <$> runningident) == Just (ident2id ident)
+ if runningident == Just ident
then return NoChange
else do
void $ stopContainer cid
- oldimage <- fromMaybe image <$> commitContainer cid
- void $ removeContainer cid
- go oldimage
- else do
- whenM (elem cid <$> listContainers AllContainers) $ do
- void $ removeContainer cid
- go image
+ restartcontainer
+ else ifM (elem cid <$> listContainers AllContainers)
+ ( restartcontainer
+ , go image
+ )
where
ident = ContainerIdent image hn cn runps
- getrunningident = catchDefaultIO Nothing $
- simpleShClient (namedPipe cid) "cat" [propellorIdent] $
- pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout
+ restartcontainer = do
+ oldimage <- fromMaybe image <$> commitContainer cid
+ void $ removeContainer cid
+ go oldimage
+
+ getrunningident :: IO (Maybe ContainerIdent)
+ getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
+ let !v = extractident rs
+ return v
+
+ extractident :: [Resp] -> Maybe ContainerIdent
+ extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
runps = getRunParams hn $ containerprops ++
-- expose propellor directory inside the container
@@ -280,6 +291,9 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId.
--
+-- This process is effectively init inside the container.
+-- It even needs to wait on zombie processes!
+--
-- Fork a thread to run the SimpleSh server in the background.
-- In the foreground, run an interactive bash (or sh) shell,
-- so that the user can interact with it when attached to the container.
@@ -305,13 +319,17 @@ chain s = case toContainerId s of
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
warningMessage "Boot provision failed!"
- void $ async $ simpleSh $ namedPipe cid
- forever $ do
- void $ ifM (inPath "bash")
+ void $ async $ job reapzombies
+ void $ async $ job $ simpleSh $ namedPipe cid
+ job $ do
+ void $ tryIO $ ifM (inPath "bash")
( boolSystem "bash" [Param "-l"]
, boolSystem "/bin/sh" []
)
putStrLn "Container is still running. Press ^P^Q to detach."
+ where
+ job = forever . void . tryIO
+ reapzombies = void $ getAnyProcessStatus True False
-- | Once a container is running, propellor can be run inside
-- it to provision it.
@@ -343,7 +361,7 @@ provisionContainer cid = containerDesc cid $ Property "provision" $ do
hPutStrLn stderr s
hFlush stderr
go Nothing rest
- Done _ -> ret lastline
+ Done -> ret lastline
go lastline [] = ret lastline
ret lastline = return $ fromMaybe FailedChange $
diff --git a/Propellor/Property/Docker/Shim.hs b/Propellor/Property/Docker/Shim.hs
index 01c2b22f..c2f35d0c 100644
--- a/Propellor/Property/Docker/Shim.hs
+++ b/Propellor/Property/Docker/Shim.hs
@@ -3,7 +3,7 @@
--
-- Note: This is currently Debian specific, due to glibcLibs.
-module Propellor.Property.Docker.Shim (setup, file) where
+module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where
import Propellor
import Utility.LinuxMkLibs
@@ -44,6 +44,9 @@ setup propellorbin dest = do
modifyFileMode shim (addModes executeModes)
return shim
+cleanEnv :: IO ()
+cleanEnv = void $ unsetEnv "GCONV_PATH"
+
file :: FilePath -> FilePath -> FilePath
file propellorbin dest = dest </> takeFileName propellorbin
diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index f4e13149..149c8e6c 100644
--- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -9,8 +9,14 @@ import Propellor.Property.Cron (CronTimes)
builduser :: UserName
builduser = "builder"
+homedir :: FilePath
+homedir = "/home/builder"
+
+gitbuilderdir :: FilePath
+gitbuilderdir = homedir </> "gitbuilder"
+
builddir :: FilePath
-builddir = "gitbuilder"
+builddir = gitbuilderdir </> "build"
builder :: Architecture -> CronTimes -> Bool -> Property
builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
@@ -20,26 +26,22 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
"liblockfile-simple-perl", "cabal-install", "vim", "less"]
, serviceRunning "cron" `requires` Apt.installed ["cron"]
, User.accountFor builduser
- , check (lacksdir builddir) $ userScriptProperty builduser
- [ "git clone git://git.kitenet.net/gitannexbuilder " ++ builddir
- , "cd " ++ builddir
+ , check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser
+ [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
+ , "cd " ++ gitbuilderdir
, "git checkout " ++ arch
]
`describe` "gitbuilder setup"
- , check (lacksdir $ builddir </> "build") $ userScriptProperty builduser
- [ "cd " ++ builddir
- , "git clone git://git-annex.branchable.com/ build"
+ , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
+ [ "git clone git://git-annex.branchable.com/ " ++ builddir
]
- , Property "git-annex source build deps installed" $ do
- d <- homedir
- ensureProperty $ Apt.buildDepIn (d </> builddir </> "build")
- , Cron.niceJob "gitannexbuilder" crontimes builduser ("~/" ++ builddir) "git pull ; ./autobuild"
+ , "git-annex source build deps installed" ==> Apt.buildDepIn builddir
+ , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir "git pull ; ./autobuild"
-- The builduser account does not have a password set,
-- instead use the password privdata to hold the rsync server
-- password used to upload the built image.
, Property "rsync password" $ do
- d <- homedir
- let f = d </> "rsyncpassword"
+ let f = homedir </> "rsyncpassword"
if rsyncupload
then withPrivData (Password builduser) $ \p -> do
oldp <- catchDefaultIO "" $ readFileStrict f
@@ -52,8 +54,3 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
, makeChange $ writeFile f "no password configured"
)
]
- where
- homedir = fromMaybe ("/home/" ++ builduser) <$> User.homedir builduser
- lacksdir d = do
- h <- homedir
- not <$> doesDirectoryExist (h </> d)
diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs
index 0999be9a..99a6fc24 100644
--- a/Propellor/SimpleSh.hs
+++ b/Propellor/SimpleSh.hs
@@ -9,7 +9,6 @@ import Network.Socket
import Control.Concurrent.Chan
import Control.Concurrent.Async
import System.Process (std_in, std_out, std_err)
-import System.Exit
import Propellor
import Utility.FileMode
@@ -18,7 +17,7 @@ import Utility.ThreadScheduler
data Cmd = Cmd String [String]
deriving (Read, Show)
-data Resp = StdoutLine String | StderrLine String | Done ExitCode
+data Resp = StdoutLine String | StderrLine String | Done
deriving (Read, Show)
simpleSh :: FilePath -> IO ()
@@ -49,7 +48,7 @@ simpleSh namedpipe = do
v <- readChan chan
hPutStrLn h (show v)
case v of
- Done _ -> noop
+ Done -> noop
_ -> runwriter
writer <- async runwriter
@@ -58,8 +57,10 @@ simpleSh namedpipe = do
void $ concurrently
(mkreader StdoutLine outh)
(mkreader StderrLine errh)
+
+ void $ tryIO $ waitForProcess pid
- writeChan chan . Done =<< waitForProcess pid
+ writeChan chan Done
wait writer
diff --git a/config-joey.hs b/config-joey.hs
index cf739d82..f2cc5e78 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -36,7 +36,6 @@ host hostname@"clam.kitenet.net" = standardSystem Unstable $ props
& Tor.isBridge
& JoeySites.oldUseNetshellBox
& Docker.configured
- ! Docker.docked container hostname "amd64-git-annex-builder"
& Docker.garbageCollected
-- Orca is the main git-annex build box.
host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
@@ -46,6 +45,8 @@ host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
& Apt.buildDep ["git-annex"]
& Docker.docked container hostname "amd64-git-annex-builder"
& Docker.docked container hostname "i386-git-annex-builder"
+ & Docker.docked container hostname "armel-git-annex-builder-companion"
+ & Docker.docked container hostname "armel-git-annex-builder"
& Docker.garbageCollected
-- My laptop
host _hostname@"darkstar.kitenet.net" = Just $ props
@@ -67,11 +68,29 @@ container _host name
& serviceRunning "apache2"
`requires` Apt.installed ["apache2"]
]
+
+ -- armel builder has a companion container that run amd64 and
+ -- runs the build first to get TH splices. They share a home
+ -- directory, and need to have the same versions of all haskell
+ -- libraries installed.
+ | name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom
+ (image $ System (Debian Unstable) "amd64")
+ [ Docker.volume GitAnnexBuilder.homedir
+ ]
+ | name == "armel-git-annex-builder" = Just $ Docker.containerFrom
+ (image $ System (Debian Unstable) "armel")
+ [ Docker.link (name ++ "-companion") "companion"
+ , Docker.volumes_from (name ++ "-companion")
+ , Docker.inside $ props
+-- & GitAnnexBuilder.builder "armel" "15 * * * *" True
+ ]
+
| "-git-annex-builder" `isSuffixOf` name =
let arch = takeWhile (/= '-') name
in Just $ Docker.containerFrom
(image $ System (Debian Unstable) arch)
[ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" True ]
+
| otherwise = Nothing
-- | Docker images I prefer to use.
diff --git a/debian/changelog b/debian/changelog
index f4eadd22..e2f955b0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,12 @@
+propellor (0.2.3) UNRELEASED; urgency=medium
+
+ * docker: Fix laziness bug that caused running containers to be
+ unnecessarily stopped and committed.
+ * Add locking so only one propellor can run at a time on a host.
+ * docker: When running as effective init inside container, wait on zombies.
+
+ -- Joey Hess <joeyh@debian.org> Fri, 04 Apr 2014 15:58:03 -0400
+
propellor (0.2.2) unstable; urgency=medium
* Now supports provisioning docker containers with architecture/libraries