summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-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))
- ]