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/Property/Docker.hs | 42 ++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 23 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') 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') -- cgit v1.3-2-g0d8e From f8b71c0ab4e09a90aeced9a563465c0b89ee1a16 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 00:38:11 -0400 Subject: propellor spin --- src/Propellor/Property/Docker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 2b4faf7b..e5d488c1 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -489,7 +489,7 @@ 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 +inContainer cid ps cmd = withHandle StdoutHandle createProcessSuccess (proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)) commitContainer :: ContainerId -> IO (Maybe Image) -- cgit v1.3-2-g0d8e From 05086b3abe8d633ae788354a3cc9bb0bd72f6159 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:02:13 -0400 Subject: propellor spin --- src/Propellor/Property/Docker.hs | 45 +++++++++++++++++++--------------------- src/Utility/Process.hs | 13 +++++++----- 2 files changed, 29 insertions(+), 29 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index e5d488c1..64276e87 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -37,13 +37,13 @@ module Propellor.Property.Docker ( ) where import Propellor -import Propellor.SimpleSh import Propellor.Types.Info import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Docker.Shim as Shim import Utility.SafeCommand import Utility.Path +import Utility.ThreadScheduler import Control.Concurrent.Async hiding (link) import System.Posix.Directory @@ -339,7 +339,7 @@ runningContainer :: ContainerId -> Image -> [RunParam] -> Property runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l - then checkident =<< liftIO (getrunningident simpleShClient) + then checkident =<< liftIO getrunningident else ifM (liftIO $ elem cid <$> listContainers AllContainers) ( do -- The container exists, but is not @@ -348,9 +348,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- starting it up first. void $ liftIO $ startContainer cid -- It can take a while for the container to - -- start up enough to get its ident, so - -- retry for up to 60 seconds. - checkident =<< liftIO (getrunningident (simpleShClientRetry 60)) + -- start up enough for its ident file to be + -- written, so retry for up to 60 seconds. + checkident =<< liftIO (retry 60 $ getrunningident) , go image ) where @@ -370,12 +370,18 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope void $ liftIO $ removeContainer cid go oldimage - getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do - let !v = extractident rs - return v + getrunningident = readish + <$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent]) - extractident :: [Resp] -> Maybe ContainerIdent - extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout + retry :: Int -> IO (Maybe a) -> IO (Maybe a) + retry 0 _ = return Nothing + retry n a = do + v <- a + case v of + Just _ -> return v + Nothing -> do + threadDelaySeconds (Seconds 1) + retry (n-1) a go img = do liftIO $ do @@ -393,7 +399,6 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- 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. -- @@ -412,14 +417,11 @@ chain s = case toContainerId s of Just cid -> do changeWorkingDirectory localdir writeFile propellorIdent . show =<< readIdentFile cid - -- Run boot provisioning before starting simpleSh, - -- 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)]) $ warningMessage "Boot provision failed!" void $ async $ job reapzombies - void $ async $ job $ simpleSh $ namedPipe cid job $ do void $ tryIO $ ifM (inPath "bash") ( boolSystem "bash" [Param "-l"] @@ -437,10 +439,11 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d let shim = Shim.file (localdir "propellor") (localdir shimdir cid) let params = ["--continue", show $ Chain (containerHostName cid)] msgh <- mkMessageHandle - r <- inContainer cid + let p = inContainerProcess cid [ if isConsole msgh then "-it" else "-i" ] (shim : params) - (processoutput Nothing) + r <- withHandle StdoutHandle createProcessSuccess p $ + processoutput Nothing when (r /= FailedChange) $ setProvisionedFlag cid return r @@ -471,7 +474,6 @@ stoppedContainer cid = containerDesc cid $ property desc $ where desc = "stopped" cleanup = do - nukeFile $ namedPipe cid nukeFile $ identFile cid removeDirectoryRecursive $ shimdir cid clearProvisionedFlag cid @@ -488,9 +490,8 @@ 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 StdoutHandle createProcessSuccess - (proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)) +inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess +inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd) commitContainer :: ContainerId -> IO (Maybe Image) commitContainer cid = catchMaybeIO $ @@ -534,10 +535,6 @@ dockerInfo i = mempty { _dockerinfo = i } propellorIdent :: FilePath propellorIdent = "/.propellor-ident" --- | Named pipe used for communication with the container. -namedPipe :: ContainerId -> FilePath -namedPipe cid = "docker" fromContainerId cid - provisionedFlag :: ContainerId -> FilePath provisionedFlag cid = "docker" fromContainerId cid ++ ".provisioned" diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index e25618eb..4550d94f 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -13,6 +13,7 @@ module Utility.Process ( CreateProcess(..), StdHandle(..), readProcess, + readProcess', readProcessEnv, writeReadProcessEnv, forceSuccessProcess, @@ -66,17 +67,19 @@ readProcess :: FilePath -> [String] -> IO String readProcess cmd args = readProcessEnv cmd args Nothing readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String -readProcessEnv cmd args environ = - withHandle StdoutHandle createProcessSuccess p $ \h -> do - output <- hGetContentsStrict h - hClose h - return output +readProcessEnv cmd args environ = readProcess' p where p = (proc cmd args) { std_out = CreatePipe , env = environ } +readProcess' :: CreateProcess -> IO String +readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do + output <- hGetContentsStrict h + hClose h + return output + {- Runs an action to write to a process on its stdin, - returns its output, and also allows specifying the environment. -} -- cgit v1.3-2-g0d8e From 4dddbb725d9694b575bb665fa2369278b383f661 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:28:38 -0400 Subject: prevent multiple concurrent provisioning inside docker container Lock a lock file while provisioning inside, otherwise propellor could be running to init the container when the system has just booted, or the container was just started from being stopped, and at the same time, propellor run outside the container chains into it to provision. Previously, simplesh prevented this in a different way. --- src/Propellor/CmdLine.hs | 26 ++++++-------------------- src/Propellor/Engine.hs | 15 +++++++++++++++ src/Propellor/Property/Docker.hs | 28 ++++++++++++++++++++-------- src/Propellor/Types.hs | 4 ++-- 4 files changed, 43 insertions(+), 30 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index e41ab39d..d9a95de2 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -7,8 +7,6 @@ import System.Environment (getArgs) import Data.List import System.Exit import System.PosixCompat -import Control.Exception (bracket) -import System.Posix.IO import Propellor import Propellor.Protocol @@ -86,10 +84,8 @@ defaultMain hostlist = do go _ (Edit field context) = editPrivData field context go _ ListFields = listPrivDataFields hostlist go _ (AddKey keyid) = addKey keyid - go _ (Chain hn) = withhost hn $ \h -> do - r <- runPropellor h $ ensureProperties $ hostProperties h - putStrLn $ "\n" ++ show r - go _ (Docker hn) = Docker.chain hn + go _ (DockerChain hn s) = withhost hn $ Docker.chain s + go _ (DockerInit hn) = Docker.init hn go _ (GitPush fin fout) = gitPushHelper fin fout go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline @@ -97,27 +93,17 @@ defaultMain hostlist = do go False cmdline@(SimpleRun hn) = buildFirst cmdline $ go False (Run hn) go False (Run hn) = ifM ((==) 0 <$> getRealUserID) - ( onlyProcess $ withhost hn mainProperties + ( onlyprocess $ withhost hn mainProperties , go True (Spin hn) ) go False (Update _) = do forceConsole - onlyProcess update + onlyprocess update withhost :: HostName -> (Host -> IO ()) -> IO () withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) - -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" + + onlyprocess = onlyProcess (localdir ".lock") unknownhost :: HostName -> [Host] -> IO a unknownhost h hosts = errorMessage $ unlines diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index a3fc0f30..3fa9ffc0 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -8,11 +8,15 @@ import Data.Monoid import Control.Applicative import System.Console.ANSI import "mtl" Control.Monad.Reader +import Control.Exception (bracket) +import System.PosixCompat +import System.Posix.IO import Propellor.Types import Propellor.Message import Propellor.Exception import Propellor.Info +import Utility.Exception runPropellor :: Host -> Propellor a -> IO a runPropellor host a = runReaderT (runWithHost a) host @@ -47,3 +51,14 @@ fromHost l hn getter = case findHost l hn of Nothing -> return Nothing Just h -> liftIO $ Just <$> runReaderT (runWithHost getter) h + +onlyProcess :: FilePath -> IO a -> IO a +onlyProcess lockfile 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!" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 64276e87..7b559a50 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -33,10 +33,11 @@ module Propellor.Property.Docker ( restartOnFailure, restartNever, -- * Internal use + init, chain, ) where -import Propellor +import Propellor hiding (init) import Propellor.Types.Info import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt @@ -48,7 +49,8 @@ import Utility.ThreadScheduler import Control.Concurrent.Async hiding (link) import System.Posix.Directory import System.Posix.Process -import Data.List +import Prelude hiding (init) +import Data.List hiding (init) import Data.List.Utils import qualified Data.Set as S @@ -391,7 +393,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope liftIO $ writeFile (identFile cid) (show ident) ensureProperty $ boolProperty "run" $ runContainer img (runps ++ ["-i", "-d", "-t"]) - [shim, "--continue", show (Docker (fromContainerId cid))] + [shim, "--continue", show (DockerInit (fromContainerId cid))] -- | Called when propellor is running inside a docker container. -- The string should be the container's ContainerId. @@ -406,20 +408,20 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- again. So, to make the necessary services get started on boot, this needs -- to provision the container then. However, if the container is already -- being provisioned by the calling propellor, it would be redundant and --- problimatic to also provisoon it here. +-- problimatic to also provisoon it here, when not booting up. -- -- The solution is a flag file. If the flag file exists, then the container -- was already provisioned. So, it must be a reboot, and time to provision -- again. If the flag file doesn't exist, don't provision here. -chain :: String -> IO () -chain s = case toContainerId s of +init :: String -> IO () +init s = case toContainerId s of Nothing -> error $ "Invalid ContainerId: " ++ s Just cid -> do changeWorkingDirectory localdir writeFile propellorIdent . show =<< readIdentFile cid whenM (checkProvisionedFlag cid) $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) - unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid)]) $ + unlessM (boolSystem shim [Param "--continue", Param $ show $ DockerChain (containerHostName cid) (fromContainerId cid)]) $ warningMessage "Boot provision failed!" void $ async $ job reapzombies job $ do @@ -437,7 +439,7 @@ chain s = case toContainerId s of 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)] + let params = ["--continue", show $ DockerChain (containerHostName cid) (fromContainerId cid)] msgh <- mkMessageHandle let p = inContainerProcess cid [ if isConsole msgh then "-it" else "-i" ] @@ -458,6 +460,13 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d hFlush stdout processoutput (Just s) h +chain :: String -> Host -> IO () +chain s h = case toContainerId s of + Just cid -> onlyProcess (provisioningLock cid) $ do + r <- runPropellor h $ ensureProperties $ hostProperties h + putStrLn $ "\n" ++ show r + Nothing -> error "bad container id" + stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] @@ -549,6 +558,9 @@ setProvisionedFlag cid = do checkProvisionedFlag :: ContainerId -> IO Bool checkProvisionedFlag = doesFileExist . provisionedFlag +provisioningLock :: ContainerId -> FilePath +provisioningLock cid = "docker" fromContainerId cid ++ ".lock" + shimdir :: ContainerId -> FilePath shimdir cid = "docker" fromContainerId cid ++ ".shim" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 00da7495..75b3c2ab 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -145,8 +145,8 @@ data CmdLine | ListFields | AddKey String | Continue CmdLine - | Chain HostName | Update HostName - | Docker HostName + | DockerInit HostName + | DockerChain HostName String | GitPush Fd Fd deriving (Read, Show, Eq) -- cgit v1.3-2-g0d8e From 1872ee1ffcd757ea2a9e78b6392d14e9f1a8bc9b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:32:09 -0400 Subject: propellor spin --- src/Propellor/Property/Docker.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 7b559a50..0fc7beec 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -462,9 +462,11 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d chain :: String -> Host -> IO () chain s h = case toContainerId s of - Just cid -> onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureProperties $ hostProperties h - putStrLn $ "\n" ++ show r + Just cid -> do + changeWorkingDirectory localdir + onlyProcess (provisioningLock cid) $ do + r <- runPropellor h $ ensureProperties $ hostProperties h + putStrLn $ "\n" ++ show r Nothing -> error "bad container id" stopContainer :: ContainerId -> IO Bool -- cgit v1.3-2-g0d8e From 803e1407a086bca6014bbaeca238772364e859d6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:40:56 -0400 Subject: improve display --- src/Propellor/Property/Docker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 0fc7beec..96405108 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -335,7 +335,7 @@ myContainerSuffix = ".propellor" containerDesc :: ContainerId -> Property -> Property containerDesc cid p = p `describe` desc where - desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p + desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p runningContainer :: ContainerId -> Image -> [RunParam] -> Property runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do -- cgit v1.3-2-g0d8e From d49d2518979c7b985af8f00741f2a91bcd511024 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 23:11:34 -0400 Subject: separate docker container type Docker containers are now a separate data type, cannot be included in the main host list, and are instead passed to Docker.docked. (API change) --- config-joey.hs | 111 ++++++++++----------- config-simple.hs | 19 ++-- debian/changelog | 3 + src/Propellor/Property.hs | 33 +++--- src/Propellor/Property/Docker.hs | 63 +++++------- .../Property/SiteSpecific/GitAnnexBuilder.hs | 10 +- src/Propellor/Types/Info.hs | 14 +-- 7 files changed, 117 insertions(+), 136 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/config-joey.hs b/config-joey.hs index 2866e797..d6f174dc 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -45,7 +45,7 @@ hosts = -- (o) ` , kite , diatom , elephant - ] ++ containers ++ monsters + ] ++ monsters darkstar :: Host darkstar = host "darkstar.kitenet.net" @@ -53,8 +53,7 @@ darkstar = host "darkstar.kitenet.net" & Apt.buildDep ["git-annex"] `period` Daily & Docker.configured - ! Docker.docked hosts "android-git-annex" - ! Docker.docked hosts "simple-debian" + ! Docker.docked gitAnnexAndroidDev clam :: Host clam = standardSystem "clam.kitenet.net" Unstable "amd64" @@ -69,7 +68,7 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64" & Docker.configured & Docker.garbageCollected `period` Daily - & Docker.docked hosts "webserver" + & Docker.docked webserver & File.dirExists "/var/www/html" & File.notPresent "/var/www/html/index.html" & "/var/www/index.html" `File.hasContent` ["hello, world"] @@ -91,11 +90,11 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64" & Apt.unattendedUpgrades & Postfix.satellite & Docker.configured - & Docker.docked hosts "amd64-git-annex-builder" - & Docker.docked hosts "i386-git-annex-builder" - & Docker.docked hosts "android-git-annex-builder" - & Docker.docked hosts "armel-git-annex-builder-companion" - & Docker.docked hosts "armel-git-annex-builder" + & Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h") + & Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h") + & Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage) + & Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h") + & Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h") & Docker.garbageCollected `period` Daily & Apt.buildDep ["git-annex"] `period` Daily @@ -258,11 +257,10 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64" & myDnsSecondary & Docker.configured - & Docker.docked hosts "oldusenet-shellbox" - & Docker.docked hosts "openid-provider" + & Docker.docked oldusenetShellBox + & Docker.docked openidProvider `requires` Apt.serviceInstalledRunning "ntp" - & Docker.docked hosts "ancient-kitenet" - + & Docker.docked ancientKitenet & Docker.garbageCollected `period` (Weekly (Just 1)) -- For https port 443, shellinabox with ssh login to @@ -284,52 +282,43 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64" ----------------------- : / ----------------------- ------------------------ \____, o ,' ------------------------ ------------------------- '--,___________,' ------------------------- -containers :: [Host] -containers = - -- Simple web server, publishing the outside host's /var/www - [ standardStableContainer "webserver" - & Docker.publish "80:80" - & Docker.volume "/var/www:/var/www" - & Apt.serviceInstalledRunning "apache2" - - -- My own openid provider. Uses php, so containerized for security - -- and administrative sanity. - , standardStableContainer "openid-provider" - & alias "openid.kitenet.net" - & Docker.publish "8081:80" - & OpenId.providerFor ["joey", "liw"] - "openid.kitenet.net:8081" - - -- Exhibit: kite's 90's website. - , standardStableContainer "ancient-kitenet" - & alias "ancient.kitenet.net" - & Docker.publish "1994:80" - & Apt.serviceInstalledRunning "apache2" - & Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www" - (Just "remotes/origin/old-kitenet.net") - - , standardStableContainer "oldusenet-shellbox" - & alias "shell.olduse.net" - & Docker.publish "4200:4200" - & JoeySites.oldUseNetShellBox - - , Docker.container "simple-debian" "debian" - & "/hello" `File.containsLine` "hello" - & Docker.publish "8081:80" - - -- git-annex autobuilder containers - , GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h" - , GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h" - , GitAnnexBuilder.armelCompanionContainer dockerImage - , GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h" - , GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h" - - -- for development of git-annex for android, using my git-annex - -- work tree - , let gitannexdir = GitAnnexBuilder.homedir "git-annex" - in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir - & Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir) - ] +-- Simple web server, publishing the outside host's /var/www +webserver :: Docker.Container +webserver = standardStableContainer "webserver" + & Docker.publish "80:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" + +-- My own openid provider. Uses php, so containerized for security +-- and administrative sanity. +openidProvider :: Docker.Container +openidProvider = standardStableContainer "openid-provider" + & alias "openid.kitenet.net" + & Docker.publish "8081:80" + & OpenId.providerFor ["joey", "liw"] + "openid.kitenet.net:8081" + +-- Exhibit: kite's 90's website. +ancientKitenet :: Docker.Container +ancientKitenet = standardStableContainer "ancient-kitenet" + & alias "ancient.kitenet.net" + & Docker.publish "1994:80" + & Apt.serviceInstalledRunning "apache2" + & Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www" + (Just "remotes/origin/old-kitenet.net") + +oldusenetShellBox :: Docker.Container +oldusenetShellBox = standardStableContainer "oldusenet-shellbox" + & alias "shell.olduse.net" + & Docker.publish "4200:4200" + & JoeySites.oldUseNetShellBox + +-- for development of git-annex for android, using my git-annex work tree +gitAnnexAndroidDev :: Docker.Container +gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir + & Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir) + where + gitannexdir = GitAnnexBuilder.homedir "git-annex" type Motd = [String] @@ -363,11 +352,11 @@ standardSystemUnhardened hn suite arch motd = host hn & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] `onChange` Apt.autoRemove -standardStableContainer :: Docker.ContainerName -> Host +standardStableContainer :: Docker.ContainerName -> Docker.Container standardStableContainer name = standardContainer name (Stable "wheezy") "amd64" -- This is my standard container setup, featuring automatic upgrades. -standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host +standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container standardContainer name suite arch = Docker.container name (dockerImage system) & os system & Apt.stdSourcesList `onChange` Apt.upgrade diff --git a/config-simple.hs b/config-simple.hs index dcdc51a3..fb02e279 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -32,18 +32,19 @@ hosts = & User.hasSomePassword "root" (Context "mybox.example.com") & Network.ipv6to4 & File.dirExists "/var/www" - & Docker.docked hosts "webserver" + & Docker.docked webserverContainer & Docker.garbageCollected `period` Daily & Cron.runPropellor "30 * * * *" - -- A generic webserver in a Docker container. - , Docker.container "webserver" "joeyh/debian-stable" - & os (System (Debian (Stable "wheezy")) "amd64") - & Apt.stdSourcesList - & Docker.publish "80:80" - & Docker.volume "/var/www:/var/www" - & Apt.serviceInstalledRunning "apache2" - -- add more hosts here... --, host "foo.example.com" = ... ] + +-- A generic webserver in a Docker container. +webserverContainer :: Docker.Container +webserverContainer = Docker.container "webserver" "joeyh/debian-stable" + & os (System (Debian (Stable "wheezy")) "amd64") + & Apt.stdSourcesList + & Docker.publish "80:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" diff --git a/debian/changelog b/debian/changelog index 83958a16..155d5124 100644 --- a/debian/changelog +++ b/debian/changelog @@ -15,6 +15,9 @@ propellor (1.0.0) UNRELEASED; urgency=medium * Avoid outputting color setting sequences when not run on a terminal. * Run remote propellor --spin with a controlling terminal. * Docker code simplified by using `docker exec`; needs docker 1.3.1. + * Docker containers are now a separate data type, cannot be included + in the main host list, and are instead passed to + Docker.docked. (API change) * Added support for using debootstrap from propellor. -- Joey Hess Mon, 10 Nov 2014 11:15:27 -0400 diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 7000b2a3..bf69ff60 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -144,27 +144,28 @@ unrevertable (RevertableProperty p1 _p2) = p1 host :: HostName -> Host host hn = Host hn [] mempty --- | Adds a property to a Host --- --- Can add Properties and RevertableProperties -(&) :: IsProp p => Host -> p -> Host -(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) - -infixl 1 & +class Hostlike h where + -- | Adds a property to a Host + -- + -- Can add Properties and RevertableProperties + (&) :: IsProp p => h -> p -> h + -- | Like (&), but adds the property as the + -- first property of the host. Normally, property + -- order should not matter, but this is useful + -- when it does. + (&^) :: IsProp p => h -> p -> h + +instance Hostlike Host where + (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) + (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) -- | Adds a property to the Host in reverted form. -(!) :: Host -> RevertableProperty -> Host +(!) :: Hostlike h => h -> RevertableProperty -> h h ! p = h & revert p -infixl 1 ! - --- | Like (&), but adds the property as the first property of the host. --- Normally, property order should not matter, but this is useful --- when it does. -(&^) :: IsProp p => Host -> p -> Host -(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) - infixl 1 &^ +infixl 1 & +infixl 1 ! -- Changes the action that is performed to satisfy a property. adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 96405108..ce9fb7d7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -16,6 +16,7 @@ module Propellor.Property.Docker ( tweaked, Image, ContainerName, + Container, -- * Container configuration dns, hostname, @@ -71,55 +72,60 @@ configured = prop `requires` installed -- only [a-zA-Z0-9_-] are allowed type ContainerName = String --- | Starts accumulating the properties of a Docker container. +-- | A docker container. +data Container = Container Image Host + +instance Hostlike Container where + (Container i h) & p = Container i (h & p) + (Container i h) &^ p = Container i (h &^ p) + +-- | Builds a Container with a given name, image, and properties. -- -- > container "web-server" "debian" -- > & publish "80:80" -- > & Apt.installed {"apache2"] -- > & ... -container :: ContainerName -> Image -> Host -container cn image = Host hn [] info +container :: ContainerName -> Image -> Container +container cn image = Container image (Host hn [] info) where - info = dockerInfo $ mempty { _dockerImage = Val image } + info = dockerInfo mempty hn = cn2hn cn cn2hn :: ContainerName -> HostName cn2hn cn = cn ++ ".docker" --- | Ensures that a docker container is set up and running, finding --- its configuration in the passed list of hosts. +-- | Ensures that a docker container is set up and running. -- -- The container has its own Properties which are handled by running -- propellor inside the container. -- -- When the container's Properties include DNS info, such as a CNAME, --- that is propigated to the Info of the host(s) it's docked in. +-- that is propigated to the Info of the Host it's docked in. -- -- Reverting this property ensures that the container is stopped and -- removed. docked - :: [Host] - -> ContainerName + :: Container -> RevertableProperty -docked hosts cn = RevertableProperty - ((maybe id propigateInfo mhost) (go "docked" setup)) +docked ctr@(Container _ h) = RevertableProperty + (propigateInfo h (go "docked" setup)) (go "undocked" teardown) where + cn = hostName h + go desc a = property (desc ++ " " ++ cn) $ do hn <- asks hostName let cid = ContainerId hn cn - ensureProperties [findContainer mhost cid cn $ a cid] - - mhost = findHostNoAlias hosts (cn2hn cn) + ensureProperties [a cid (mkContainerInfo cid ctr)] - setup cid (Container image runparams) = + setup cid (ContainerInfo image runparams) = provisionContainer cid `requires` runningContainer cid image runparams `requires` installed - teardown cid (Container image _runparams) = + teardown cid (ContainerInfo image _runparams) = combineProperties ("undocked " ++ fromContainerId cid) [ stoppedContainer cid , property ("cleaned up " ++ fromContainerId cid) $ @@ -136,26 +142,11 @@ propigateInfo (Host _ _ containerinfo) p = dnsprops = map addDNS (S.toList $ _dns containerinfo) privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) -findContainer - :: Maybe Host - -> ContainerId - -> ContainerName - -> (Container -> Property) - -> Property -findContainer mhost cid cn mk = case mhost of - Nothing -> cantfind - Just h -> maybe cantfind mk (mkContainer cid h) - where - cantfind = containerDesc cid $ property "" $ do - liftIO $ warningMessage $ - "missing definition for docker container \"" ++ cn2hn cn - return FailedChange - -mkContainer :: ContainerId -> Host -> Maybe Container -mkContainer cid@(ContainerId hn _cn) h = Container - <$> fromVal (_dockerImage info) - <*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info)) +mkContainerInfo :: ContainerId -> Container -> ContainerInfo +mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = + ContainerInfo img runparams where + runparams = map (\mkparam -> mkparam hn) (_dockerRunParams info) info = _dockerinfo $ hostInfo h' h' = h -- Restart by default so container comes up on @@ -209,7 +200,7 @@ memoryLimited = "/etc/default/grub" `File.containsLine` cfg cmdline = "cgroup_enable=memory swapaccount=1" cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" -data Container = Container Image [RunParam] +data ContainerInfo = ContainerInfo Image [RunParam] -- | Parameters to pass to `docker run` when creating a container. type RunParam = String diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 901eba2e..0208dea6 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -88,7 +88,7 @@ cabalDeps = flagFile go cabalupdated go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] cabalupdated = homedir ".cabal" "packages" "hackage.haskell.org" "00-index.cache" -standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host +standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder") (dockerImage $ System (Debian Testing) arch) & os (System (Debian Testing) arch) @@ -101,14 +101,14 @@ standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.conta & autobuilder arch (show buildminute ++ " * * * *") timeout & Docker.tweaked -androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host +androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container androidAutoBuilderContainer dockerImage crontimes timeout = androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir & Apt.unattendedUpgrades & autobuilder "android" crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. -androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host +androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name (dockerImage osver) & os osver @@ -137,7 +137,7 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe -- armel builder has a companion container using amd64 that -- runs the build first to get TH splices. They need -- to have the same versions of all haskell libraries installed. -armelCompanionContainer :: (System -> Docker.Image) -> Host +armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion" (dockerImage $ System (Debian Unstable) "amd64") & os (System (Debian Testing) "amd64") @@ -156,7 +156,7 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder- & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") & Docker.tweaked -armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host +armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" (dockerImage $ System (Debian Unstable) "armel") & os (System (Debian Testing) "armel") diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index de072aa0..6aba1f9f 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -45,26 +45,22 @@ fromVal (Val a) = Just a fromVal NoVal = Nothing data DockerInfo = DockerInfo - { _dockerImage :: Val String - , _dockerRunParams :: [HostName -> String] + { _dockerRunParams :: [HostName -> String] } instance Eq DockerInfo where x == y = and - [ _dockerImage x == _dockerImage y - , let simpl v = map (\a -> a "") (_dockerRunParams v) + [ let simpl v = map (\a -> a "") (_dockerRunParams v) in simpl x == simpl y ] instance Monoid DockerInfo where - mempty = DockerInfo mempty mempty + mempty = DockerInfo mempty mappend old new = DockerInfo - { _dockerImage = _dockerImage old <> _dockerImage new - , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + { _dockerRunParams = _dockerRunParams old <> _dockerRunParams new } instance Show DockerInfo where show a = unlines - [ "docker image " ++ show (_dockerImage a) - , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) + [ "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) ] -- cgit v1.3-2-g0d8e From 5e4c57652cef29d9729dce22da3f98dc909b3ff2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 20 Nov 2014 00:21:40 -0400 Subject: fix docker container provisioning Since the containers are no longer on the host list, they were not found while provisioning, oops. To fix, had to add to a host's info a map of the containers docked to it. Unfortunately, that required Propellor.Types.Info be glommed into Propellor.Types, since it needed to refer to Host. --- propellor.cabal | 1 - src/Propellor/CmdLine.hs | 2 +- src/Propellor/Info.hs | 1 - src/Propellor/PrivData.hs | 1 - src/Propellor/Property/Dns.hs | 1 - src/Propellor/Property/Docker.hs | 54 +++++++++++++++++------------- src/Propellor/Types.hs | 71 ++++++++++++++++++++++++++++++++++++++-- src/Propellor/Types/Info.hs | 66 ------------------------------------- 8 files changed, 101 insertions(+), 96 deletions(-) delete mode 100644 src/Propellor/Types/Info.hs (limited to 'src/Propellor/Property/Docker.hs') diff --git a/propellor.cabal b/propellor.cabal index 161e4779..38e3da21 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -113,7 +113,6 @@ Library Propellor.Types.Dns Propellor.Types.PrivData Other-Modules: - Propellor.Types.Info Propellor.Git Propellor.Gpg Propellor.Server diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index e42e2408..8b958a7e 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -84,7 +84,7 @@ defaultMain hostlist = do go _ (Edit field context) = editPrivData field context go _ ListFields = listPrivDataFields hostlist go _ (AddKey keyid) = addKey keyid - go _ (DockerChain hn s) = withhost hn $ Docker.chain s + go _ (DockerChain hn cid) = Docker.chain hostlist hn cid go _ (DockerInit hn) = Docker.init hn go _ (GitPush fin fout) = gitPushHelper fin fout go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update) diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index f44d1de3..a91f69c8 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -3,7 +3,6 @@ module Propellor.Info where import Propellor.Types -import Propellor.Types.Info import "mtl" Control.Monad.Reader import qualified Data.Set as S diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index a5150432..c5f489e5 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -15,7 +15,6 @@ import qualified Data.Map as M import qualified Data.Set as S import Propellor.Types -import Propellor.Types.Info import Propellor.Message import Propellor.Info import Propellor.Gpg diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 135c765d..f351804c 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -15,7 +15,6 @@ module Propellor.Property.Dns ( import Propellor import Propellor.Types.Dns import Propellor.Property.File -import Propellor.Types.Info import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import Utility.Applicative diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ce9fb7d7..676d323a 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -39,7 +39,6 @@ module Propellor.Property.Docker ( ) where import Propellor hiding (init) -import Propellor.Types.Info import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Docker.Shim as Shim @@ -54,6 +53,7 @@ import Prelude hiding (init) import Data.List hiding (init) import Data.List.Utils import qualified Data.Set as S +import qualified Data.Map as M installed :: Property installed = Apt.installed ["docker.io"] @@ -86,13 +86,9 @@ instance Hostlike Container where -- > & Apt.installed {"apache2"] -- > & ... container :: ContainerName -> Image -> Container -container cn image = Container image (Host hn [] info) +container cn image = Container image (Host cn [] info) where info = dockerInfo mempty - hn = cn2hn cn - -cn2hn :: ContainerName -> HostName -cn2hn cn = cn ++ ".docker" -- | Ensures that a docker container is set up and running. -- @@ -108,7 +104,7 @@ docked :: Container -> RevertableProperty docked ctr@(Container _ h) = RevertableProperty - (propigateInfo h (go "docked" setup)) + (propigateInfo ctr (go "docked" setup)) (go "undocked" teardown) where cn = hostName h @@ -135,10 +131,12 @@ docked ctr@(Container _ h) = RevertableProperty ] ] -propigateInfo :: Host -> Property -> Property -propigateInfo (Host _ _ containerinfo) p = - combineProperties (propertyDesc p) $ p : dnsprops ++ privprops +propigateInfo :: Container -> Property -> Property +propigateInfo (Container _ h@(Host hn _ containerinfo)) p = + combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops where + p' = p { propertyInfo = propertyInfo p <> dockerinfo } + dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h } dnsprops = map addDNS (S.toList $ _dns containerinfo) privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) @@ -146,7 +144,8 @@ mkContainerInfo :: ContainerId -> Container -> ContainerInfo mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = ContainerInfo img runparams where - runparams = map (\mkparam -> mkparam hn) (_dockerRunParams info) + runparams = map (\(DockerRunParam mkparam) -> mkparam hn) + (_dockerRunParams info) info = _dockerinfo $ hostInfo h' h' = h -- Restart by default so container comes up on @@ -294,7 +293,10 @@ restartNever = runProp "restart" "no" -- | A container is identified by its name, and the host -- on which it's deployed. -data ContainerId = ContainerId HostName ContainerName +data ContainerId = ContainerId + { containerHostName :: HostName + , containerName :: ContainerName + } deriving (Eq, Read, Show) -- | Two containers with the same ContainerIdent were started from @@ -317,9 +319,6 @@ toContainerId s fromContainerId :: ContainerId -> String fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix -containerHostName :: ContainerId -> HostName -containerHostName (ContainerId _ cn) = cn2hn cn - myContainerSuffix :: String myContainerSuffix = ".propellor" @@ -412,7 +411,7 @@ init s = case toContainerId s of writeFile propellorIdent . show =<< readIdentFile cid whenM (checkProvisionedFlag cid) $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) - unlessM (boolSystem shim [Param "--continue", Param $ show $ DockerChain (containerHostName cid) (fromContainerId cid)]) $ + unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $ warningMessage "Boot provision failed!" void $ async $ job reapzombies job $ do @@ -430,7 +429,7 @@ init s = case toContainerId s of provisionContainer :: ContainerId -> Property provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) - let params = ["--continue", show $ DockerChain (containerHostName cid) (fromContainerId cid)] + let params = ["--continue", show $ toChain cid] msgh <- mkMessageHandle let p = inContainerProcess cid [ if isConsole msgh then "-it" else "-i" ] @@ -451,14 +450,23 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d hFlush stdout processoutput (Just s) h -chain :: String -> Host -> IO () -chain s h = case toContainerId s of - Just cid -> do +toChain :: ContainerId -> CmdLine +toChain cid = DockerChain (containerHostName cid) (fromContainerId cid) + +chain :: [Host] -> HostName -> String -> IO () +chain hostlist hn s = case toContainerId s of + Nothing -> errorMessage "bad container id" + Just cid -> case findHostNoAlias hostlist hn of + Nothing -> errorMessage ("cannot find host " ++ hn) + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ _dockerinfo $ hostInfo parenthost) of + Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) + Just h -> go cid h + where + go cid h = do changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do r <- runPropellor h $ ensureProperties $ hostProperties h putStrLn $ "\n" ++ show r - Nothing -> error "bad container id" stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] @@ -520,13 +528,13 @@ listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] runProp :: String -> RunParam -> Property runProp field val = pureInfoProperty (param) $ dockerInfo $ - mempty { _dockerRunParams = [\_ -> "--"++param] } + mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where param = field++"="++val genProp :: String -> (HostName -> RunParam) -> Property genProp field mkval = pureInfoProperty field $ dockerInfo $ - mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] } + mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } dockerInfo :: DockerInfo -> Info dockerInfo i = mempty { _dockerinfo = i } diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 75b3c2ab..90c08e64 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -3,7 +3,7 @@ module Propellor.Types ( Host(..) - , Info + , Info(..) , getInfo , Propellor(..) , Property(..) @@ -21,6 +21,10 @@ module Propellor.Types , Context(..) , anyContext , SshKeyType(..) + , Val(..) + , fromVal + , DockerInfo(..) + , DockerRunParam(..) , module Propellor.Types.OS , module Propellor.Types.Dns ) where @@ -31,8 +35,10 @@ import System.Console.ANSI import System.Posix.Types import "mtl" Control.Monad.Reader import "MonadCatchIO-transformers" Control.Monad.CatchIO +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Propellor.Types.Dns as Dns -import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns import Propellor.Types.PrivData @@ -150,3 +156,64 @@ data CmdLine | DockerChain HostName String | GitPush Fd Fd deriving (Read, Show, Eq) + +-- | Information about a host. +data Info = Info + { _os :: Val System + , _privDataFields :: S.Set (PrivDataField, Context) + , _sshPubKey :: Val String + , _aliases :: S.Set HostName + , _dns :: S.Set Dns.Record + , _namedconf :: Dns.NamedConfMap + , _dockerinfo :: DockerInfo + } + deriving (Eq, Show) + +instance Monoid Info where + mempty = Info mempty mempty mempty mempty mempty mempty mempty + mappend old new = Info + { _os = _os old <> _os new + , _privDataFields = _privDataFields old <> _privDataFields new + , _sshPubKey = _sshPubKey old <> _sshPubKey new + , _aliases = _aliases old <> _aliases new + , _dns = _dns old <> _dns new + , _namedconf = _namedconf old <> _namedconf new + , _dockerinfo = _dockerinfo old <> _dockerinfo new + } + +data Val a = Val a | NoVal + deriving (Eq, Show) + +instance Monoid (Val a) where + mempty = NoVal + mappend old new = case new of + NoVal -> old + _ -> new + +fromVal :: Val a -> Maybe a +fromVal (Val a) = Just a +fromVal NoVal = Nothing + +data DockerInfo = DockerInfo + { _dockerRunParams :: [DockerRunParam] + , _dockerContainers :: M.Map String Host + } + deriving (Show) + +instance Monoid DockerInfo where + mempty = DockerInfo mempty mempty + mappend old new = DockerInfo + { _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + , _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) + } + +instance Eq DockerInfo where + x == y = and + [ let simpl v = map (\(DockerRunParam a) -> a "") (_dockerRunParams v) + in simpl x == simpl y + ] + +newtype DockerRunParam = DockerRunParam (HostName -> String) + +instance Show DockerRunParam where + show (DockerRunParam a) = a "" diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs deleted file mode 100644 index 6aba1f9f..00000000 --- a/src/Propellor/Types/Info.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Propellor.Types.Info where - -import Propellor.Types.OS -import Propellor.Types.PrivData -import qualified Propellor.Types.Dns as Dns - -import qualified Data.Set as S -import Data.Monoid - --- | Information about a host. -data Info = Info - { _os :: Val System - , _privDataFields :: S.Set (PrivDataField, Context) - , _sshPubKey :: Val String - , _aliases :: S.Set HostName - , _dns :: S.Set Dns.Record - , _namedconf :: Dns.NamedConfMap - , _dockerinfo :: DockerInfo - } - deriving (Eq, Show) - -instance Monoid Info where - mempty = Info mempty mempty mempty mempty mempty mempty mempty - mappend old new = Info - { _os = _os old <> _os new - , _privDataFields = _privDataFields old <> _privDataFields new - , _sshPubKey = _sshPubKey old <> _sshPubKey new - , _aliases = _aliases old <> _aliases new - , _dns = _dns old <> _dns new - , _namedconf = _namedconf old <> _namedconf new - , _dockerinfo = _dockerinfo old <> _dockerinfo new - } - -data Val a = Val a | NoVal - deriving (Eq, Show) - -instance Monoid (Val a) where - mempty = NoVal - mappend old new = case new of - NoVal -> old - _ -> new - -fromVal :: Val a -> Maybe a -fromVal (Val a) = Just a -fromVal NoVal = Nothing - -data DockerInfo = DockerInfo - { _dockerRunParams :: [HostName -> String] - } - -instance Eq DockerInfo where - x == y = and - [ let simpl v = map (\a -> a "") (_dockerRunParams v) - in simpl x == simpl y - ] - -instance Monoid DockerInfo where - mempty = DockerInfo mempty - mappend old new = DockerInfo - { _dockerRunParams = _dockerRunParams old <> _dockerRunParams new - } - -instance Show DockerInfo where - show a = unlines - [ "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) - ] -- cgit v1.3-2-g0d8e