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

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

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)

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

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

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

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 :: Container -> Property -> Property
-propigateInfo (Host _ _ containerinfo) p =
+propigateInfo (Container _ h@(Host hn _ containerinfo)) p =
-	combineProperties (propertyDesc p) $ p : dnsprops ++ privprops
+	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 ()
+toChain :: ContainerId -> CmdLine
-chain s h = case toContainerId s of
+toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
-	Just cid -> do
+
+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 }

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

src/Propellor/Types/Info.hs

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