cadey
/
propellor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Joey Hess 2014-11-20 00:21:40 -04:00
parent 9d6bc4a7bf
commit 5e4c57652c
8 changed files with 101 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
propellor.cabal
View File

@ -113,7 +113,6 @@ Library
Propellor.Types.Dns
Propellor.Types.PrivData
Other-Modules:
Propellor.Types.Info
Propellor.Git
Propellor.Gpg
Propellor.Server

2
src/Propellor/CmdLine.hs
View File

@ -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)

1
src/Propellor/Info.hs
View File

@ -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

1
src/Propellor/PrivData.hs
View File

@ -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

1
src/Propellor/Property/Dns.hs
View File

@ -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

54
src/Propellor/Property/Docker.hs
View File

@ -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 }

71
src/Propellor/Types.hs
View File

@ -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 ""

66
src/Propellor/Types/Info.hs
View File

@ -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))
]