summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-11-20 00:21:40 -0400
committerJoey Hess2014-11-20 00:21:40 -0400
commit5e4c57652cef29d9729dce22da3f98dc909b3ff2 (patch)
treef76fb132cdbb9f572916aebdecad519c6aca8b47
parent9d6bc4a7bf54a57755a6fbbd29879d82b99ba952 (diff)
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.
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/CmdLine.hs2
-rw-r--r--src/Propellor/Info.hs1
-rw-r--r--src/Propellor/PrivData.hs1
-rw-r--r--src/Propellor/Property/Dns.hs1
-rw-r--r--src/Propellor/Property/Docker.hs54
-rw-r--r--src/Propellor/Types.hs71
-rw-r--r--src/Propellor/Types/Info.hs66
8 files changed, 101 insertions, 96 deletions
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))
- ]