From dac6a874195a521714db48083b3222c2c8b41fa9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 18 Nov 2014 22:10:50 -0400 Subject: broke out Server module --- propellor.cabal | 1 + 1 file changed, 1 insertion(+) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 2a8e3a02..c0b8624e 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -115,6 +115,7 @@ Library Propellor.CmdLine Propellor.Git Propellor.Gpg + Propellor.Server Propellor.SimpleSh Propellor.Ssh Propellor.PrivData.Paths -- cgit v1.3-2-g0d8e From 745f9e268511fb13743dfa10476fa03c616fcdf1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 18 Nov 2014 23:50:38 -0400 Subject: clean up Propellr.CmdLine exports --- propellor.cabal | 2 +- src/Propellor/CmdLine.hs | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index c0b8624e..82880d1e 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -101,6 +101,7 @@ Library Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.GitAnnexBuilder + Propellor.CmdLine Propellor.Info Propellor.Message Propellor.PrivData @@ -112,7 +113,6 @@ Library Propellor.Types.PrivData Other-Modules: Propellor.Types.Info - Propellor.CmdLine Propellor.Git Propellor.Gpg Propellor.Server diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 0ae79ac3..9006d903 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -1,4 +1,7 @@ -module Propellor.CmdLine where +module Propellor.CmdLine ( + defaultMain, + processCmdLine, +) where import System.Environment (getArgs) import Data.List @@ -68,6 +71,7 @@ processCmdLine = go =<< getArgs Just pf -> return $ f pf (Context c) Nothing -> errorMessage $ "Unknown privdata field " ++ s +-- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () defaultMain hostlist = do DockerShim.cleanEnv -- cgit v1.3-2-g0d8e From c3962dcf7db5f4692a45fe0ff9802f819a97e2d7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:04:11 -0400 Subject: propellor spin --- debian/changelog | 1 + propellor.cabal | 1 - src/Propellor/SimpleSh.hs | 101 ---------------------------------------------- 3 files changed, 1 insertion(+), 102 deletions(-) delete mode 100644 src/Propellor/SimpleSh.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index 1e16fe4a..d29da290 100644 --- a/debian/changelog +++ b/debian/changelog @@ -14,6 +14,7 @@ propellor (0.9.3) UNRELEASED; urgency=medium kernel when necessary. * 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.2.0. -- Joey Hess Mon, 10 Nov 2014 11:15:27 -0400 diff --git a/propellor.cabal b/propellor.cabal index 82880d1e..d8a2ec40 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -116,7 +116,6 @@ Library Propellor.Git Propellor.Gpg Propellor.Server - Propellor.SimpleSh Propellor.Ssh Propellor.PrivData.Paths Propellor.Protocol diff --git a/src/Propellor/SimpleSh.hs b/src/Propellor/SimpleSh.hs deleted file mode 100644 index cc5c62cd..00000000 --- a/src/Propellor/SimpleSh.hs +++ /dev/null @@ -1,101 +0,0 @@ --- | Simple server, using a named pipe. Client connects, sends a command, --- and gets back all the output from the command, in a stream. --- --- This is useful for eg, docker. - -module Propellor.SimpleSh where - -import Network.Socket -import Control.Concurrent -import Control.Concurrent.Async -import System.Process (std_in, std_out, std_err) - -import Propellor -import Utility.FileMode -import Utility.ThreadScheduler - -data Cmd = Cmd String [String] - deriving (Read, Show) - -data Resp = StdoutLine String | StderrLine String | Done - deriving (Read, Show) - -simpleSh :: FilePath -> IO () -simpleSh namedpipe = do - nukeFile namedpipe - let dir = takeDirectory namedpipe - createDirectoryIfMissing True dir - modifyFileMode dir (removeModes otherGroupModes) - s <- socket AF_UNIX Stream defaultProtocol - bindSocket s (SockAddrUnix namedpipe) - listen s 2 - forever $ do - (client, _addr) <- accept s - forkIO $ do - h <- socketToHandle client ReadWriteMode - maybe noop (run h) . readish =<< hGetLine h - where - run h (Cmd cmd params) = do - chan <- newChan - let runwriter = do - v <- readChan chan - hPutStrLn h (show v) - hFlush h - case v of - Done -> noop - _ -> runwriter - writer <- async runwriter - - flip catchIO (\_e -> writeChan chan Done) $ do - let p = (proc cmd params) - { std_in = Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - (Nothing, Just outh, Just errh, pid) <- createProcess p - - let mkreader t from = maybe noop (const $ mkreader t from) - =<< catchMaybeIO (writeChan chan . t =<< hGetLine from) - void $ concurrently - (mkreader StdoutLine outh) - (mkreader StderrLine errh) - - void $ tryIO $ waitForProcess pid - - writeChan chan Done - - hClose outh - hClose errh - - wait writer - hClose h - -simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a -simpleShClient namedpipe cmd params handler = do - s <- socket AF_UNIX Stream defaultProtocol - connect s (SockAddrUnix namedpipe) - h <- socketToHandle s ReadWriteMode - hPutStrLn h $ show $ Cmd cmd params - hFlush h - resps <- catMaybes . map readish . lines <$> hGetContents h - v <- hClose h `after` handler resps - return v - -simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a -simpleShClientRetry retries namedpipe cmd params handler = go retries - where - run = simpleShClient namedpipe cmd params handler - go n - | n < 1 = run - | otherwise = do - v <- tryIO run - case v of - Right r -> return r - Left e -> do - debug ["simplesh connection retry", show e] - threadDelaySeconds (Seconds 1) - go (n - 1) - -getStdout :: Resp -> Maybe String -getStdout (StdoutLine s) = Just s -getStdout _ = Nothing -- cgit v1.3-2-g0d8e From 409e20a69e91397d69be794367ddf3fc9be4ac57 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:41:50 -0400 Subject: big 1.0 --- debian/changelog | 2 +- propellor.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index d29da290..e575ddd8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,4 +1,4 @@ -propellor (0.9.3) UNRELEASED; urgency=medium +propellor (1.0.0) UNRELEASED; urgency=medium * propellor --spin can now be used to update remote hosts, without any central git repository needed. The central git repository is diff --git a/propellor.cabal b/propellor.cabal index d8a2ec40..9a1df40b 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 0.9.3 +Version: 1.0.0 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess -- cgit v1.3-2-g0d8e From 4a9bbd1391b708d72a455cc00f698a80f1fd5fa5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 19:30:51 -0400 Subject: Added support for using debootstrap from propellor. Most of the hard part was making it be able to install debootstrap from source, for use on non-debian-derived systems. --- debian/changelog | 3 +- propellor.cabal | 1 + src/Propellor/Property.hs | 4 + src/Propellor/Property/Debootstrap.hs | 218 ++++++++++++++++++++++++++++++++++ 4 files changed, 225 insertions(+), 1 deletion(-) create mode 100644 src/Propellor/Property/Debootstrap.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index 63adc6fe..0f4a06af 100644 --- a/debian/changelog +++ b/debian/changelog @@ -15,8 +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.2.0. + * Added support for using debootstrap from propellor. - -- Joey Hess Mon, 10 Nov 2014 11:15:27 -0400 + -- Joey Hess Mon, 10 Nov 2014 11:15:27 -0400 propellor (0.9.2) unstable; urgency=medium diff --git a/propellor.cabal b/propellor.cabal index 9a1df40b..161e4779 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -75,6 +75,7 @@ Library Propellor.Property.Cmd Propellor.Property.Hostname Propellor.Property.Cron + Propellor.Property.Debootstrap Propellor.Property.Dns Propellor.Property.Docker Propellor.Property.File diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 9545979c..7000b2a3 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -131,6 +131,10 @@ boolProperty desc a = property desc $ ifM (liftIO a) revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 +-- | Turns a revertable property into a regular property. +unrevertable :: RevertableProperty -> Property +unrevertable (RevertableProperty p1 _p2) = p1 + -- | Starts accumulating the properties of a Host. -- -- > host "example.com" diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs new file mode 100644 index 00000000..8f93fe5b --- /dev/null +++ b/src/Propellor/Property/Debootstrap.hs @@ -0,0 +1,218 @@ +module Propellor.Property.Debootstrap ( + Url, + debootstrapped, + installed, + debootstrapPath, +) where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Utility.Path +import Utility.SafeCommand +import Utility.FileMode + +import Data.List +import Data.Char +import Control.Exception +import System.Posix.Directory + +type Url = String + +-- | Builds a chroot in the given directory using debootstrap. +-- +-- The System can be any OS and architecture that debootstrap +-- and the kernel support. +debootstrapped :: FilePath -> System -> [CommandParam] -> Property +debootstrapped target system@(System _ arch) extraparams = + check (unpopulated target) prop + `requires` unrevertable installed + where + unpopulated d = null <$> catchDefaultIO [] (dirContents d) + + prop = property ("debootstrapped " ++ target) $ liftIO $ do + createDirectoryIfMissing True target + let suite = case extractSuite system of + Nothing -> error $ "don't know how to debootstrap " ++ show system + Just s -> s + let params = extraparams ++ + [ Param suite + , Param target + , Param $ "--arch=" ++ arch + ] + cmd <- fromMaybe "debootstrap" <$> debootstrapPath + ifM (boolSystem cmd params) + ( do + fixForeignDev target + return MadeChange + , return FailedChange + ) + +extractSuite :: System -> Maybe String +extractSuite (System (Debian s) _) = Just $ Apt.showSuite s +extractSuite (System (Ubuntu r) _) = Just r + +-- | Ensures debootstrap is installed. +-- +-- When necessary, falls back to installing debootstrap from source. +-- Note that installation from source is done by downloading the tarball +-- from a Debian mirror, with no cryptographic verification. +installed :: RevertableProperty +installed = RevertableProperty install remove + where + install = withOS "debootstrap installed" $ \o -> + ifM (liftIO $ isJust <$> debootstrapPath) + ( return NoChange + , ensureProperty (installon o) + ) + + installon (Just (System (Debian _) _)) = aptinstall + installon (Just (System (Ubuntu _) _)) = aptinstall + installon _ = sourceInstall + + remove = withOS "debootstrap removed" $ ensureProperty . removefrom + removefrom (Just (System (Debian _) _)) = aptremove + removefrom (Just (System (Ubuntu _) _)) = aptremove + removefrom _ = sourceRemove + + aptinstall = Apt.installed ["debootstrap"] + aptremove = Apt.removed ["debootstrap"] + +sourceInstall :: Property +sourceInstall = property "debootstrap installed from source" + (liftIO sourceInstall') + +sourceInstall' :: IO Result +sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do + let indexfile = tmpd "index.html" + unlessM (download baseurl indexfile) $ + error $ "Failed to download " ++ baseurl + urls <- reverse . sort -- highest version first + . filter ("debootstrap_" `isInfixOf`) + . filter (".tar." `isInfixOf`) + . extractUrls baseurl <$> + readFileStrictAnyEncoding indexfile + nukeFile indexfile + + tarfile <- case urls of + (tarurl:_) -> do + let f = tmpd takeFileName tarurl + unlessM (download tarurl f) $ + error $ "Failed to download " ++ tarurl + return f + _ -> error $ "Failed to find any debootstrap tarballs listed on " ++ baseurl + + createDirectoryIfMissing True localInstallDir + bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do + changeWorkingDirectory localInstallDir + unlessM (boolSystem "tar" [Param "xf", File tarfile]) $ + error "Failed to extract debootstrap tar file" + nukeFile tarfile + l <- dirContents "." + case l of + (subdir:[]) -> do + changeWorkingDirectory subdir + makeDevicesTarball + makeWrapperScript (localInstallDir subdir) + return MadeChange + _ -> error "debootstrap tar file did not contain exactly one dirctory" + +sourceRemove :: Property +sourceRemove = property "debootstrap not installed from source" $ liftIO $ + ifM (doesDirectoryExist sourceInstallDir) + ( do + removeDirectoryRecursive sourceInstallDir + return MadeChange + , return NoChange + ) + +sourceInstallDir :: FilePath +sourceInstallDir = "/usr/local/propellor/debootstrap" + +wrapperScript :: FilePath +wrapperScript = sourceInstallDir "debootstrap.wrapper" + +-- | Finds debootstrap in PATH, but fall back to looking for the +-- wrapper script that is installed, outside the PATH, when debootstrap +-- is installed from source. +debootstrapPath :: IO (Maybe FilePath) +debootstrapPath = getM searchPath + [ "debootstrap" + , wrapperScript + ] + +makeWrapperScript :: FilePath -> IO () +makeWrapperScript dir = do + createDirectoryIfMissing True (takeDirectory wrapperScript) + writeFile wrapperScript $ unlines + [ "#!/bin/sh" + , "set -e" + , "DEBOOTSTRAP_DIR=" ++ dir + , "export DEBOOTSTRAP_DIR" + , dir "debootstrap" ++ " \"$@\"" + ] + modifyFileMode wrapperScript (addModes $ readModes ++ executeModes) + +-- Work around for http://bugs.debian.org/770217 +makeDevicesTarball :: IO () +makeDevicesTarball = do + -- TODO append to tarball; avoid writing to /dev + writeFile foreignDevFlag "1" + ok <- boolSystem "sh" [Param "-c", Param tarcmd] + nukeFile foreignDevFlag + unless ok $ + error "Failed to tar up /dev to generate devices.tar.gz" + where + tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz" + +fixForeignDev :: FilePath -> IO () +fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ + void $ boolSystem "chroot" + [ File target + , Param "sh" + , Param "-c" + , Param $ intercalate " && " + [ "rm -rf /dev" + , "mkdir /dev" + , "cd /dev" + , "/sbin/MAKEDEV std ptmx fd consoleonly" + ] + ] + +foreignDevFlag :: FilePath +foreignDevFlag = "/dev/.propellor-foreign-dev" + +localInstallDir :: FilePath +localInstallDir = "/usr/local/debootstrap" + +-- This http server directory listing is relied on to be fairly sane, +-- which is one reason why it's using a specific server and not a +-- round-robin address. +baseurl :: Url +baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/" + +download :: Url -> FilePath -> IO Bool +download url dest = anyM id + [ boolSystem "curl" [Param "-o", File dest, Param url] + , boolSystem "wget" [Param "-O", File dest, Param url] + ] + +-- Pretty hackish, but I don't want to pull in a whole html parser +-- or parsec dependency just for this. +-- +-- To simplify parsing, lower case everything. This is ok because +-- the filenames are all lower-case anyway. +extractUrls :: Url -> String -> [Url] +extractUrls base = collect [] . map toLower + where + collect l [] = l + collect l ('h':'r':'e':'f':'=':r) = case r of + ('"':r') -> findend l r' + _ -> findend l r + collect l (_:cs) = collect l cs + + findend l s = + let (u, r) = break (== '"') s + u' = if "http" `isPrefixOf` u + then u + else base u + in collect (u':l) r -- 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 'propellor.cabal') 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