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. --- 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 ------------------------------------- 7 files changed, 101 insertions(+), 95 deletions(-) delete mode 100644 src/Propellor/Types/Info.hs (limited to 'src') 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.2.3