Merge branch 'joeyconfig'

1 files changed, 104 insertions, 98 deletions

diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 491955dd..676d323a 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -16,6 +16,7 @@ module Propellor.Property.Docker (
 	tweaked,
 	Image,
 	ContainerName,
+	Container,
 	-- * Container configuration
 	dns,
 	hostname,
@@ -33,24 +34,26 @@ module Propellor.Property.Docker (
 	restartOnFailure,
 	restartNever,
 	-- * Internal use
+	init,
 	chain,
 ) where
 
-import Propellor
-import Propellor.SimpleSh
-import Propellor.Types.Info
+import Propellor hiding (init)
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Docker.Shim as Shim
 import Utility.SafeCommand
 import Utility.Path
+import Utility.ThreadScheduler
 
 import Control.Concurrent.Async hiding (link)
 import System.Posix.Directory
 import System.Posix.Process
-import Data.List
+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"]
@@ -69,55 +72,56 @@ configured = prop `requires` installed
 -- only [a-zA-Z0-9_-] are allowed
 type ContainerName = String
 
--- | Starts accumulating the properties of a Docker container.
+-- | A docker container.
+data Container = Container Image Host
+
+instance Hostlike Container where
+	(Container i h) & p = Container i (h & p)
+	(Container i h) &^ p = Container i (h &^ p)
+
+-- | Builds a Container with a given name, image, and properties.
 --
 -- > container "web-server" "debian"
 -- >    & publish "80:80"
 -- >    & Apt.installed {"apache2"]
 -- >    & ...
-container :: ContainerName -> Image -> Host
-container cn image = Host hn [] info
+container :: ContainerName -> Image -> Container
+container cn image = Container image (Host cn [] info)
   where
-	info = dockerInfo $ mempty { _dockerImage = Val image }
-	hn = cn2hn cn
+	info = dockerInfo mempty
 
-cn2hn :: ContainerName -> HostName
-cn2hn cn = cn ++ ".docker"
-
--- | Ensures that a docker container is set up and running, finding
--- its configuration in the passed list of hosts.
+-- | Ensures that a docker container is set up and running.
 -- 
 -- The container has its own Properties which are handled by running
 -- propellor inside the container.
 --
 -- When the container's Properties include DNS info, such as a CNAME,
--- that is propigated to the Info of the host(s) it's docked in.
+-- that is propigated to the Info of the Host it's docked in.
 --
 -- Reverting this property ensures that the container is stopped and
 -- removed.
 docked
-	:: [Host]
-	-> ContainerName
+	:: Container
 	-> RevertableProperty
-docked hosts cn = RevertableProperty
-	((maybe id propigateInfo mhost) (go "docked" setup))
+docked ctr@(Container _ h) = RevertableProperty
+	(propigateInfo ctr (go "docked" setup))
 	(go "undocked" teardown)
   where
+	cn = hostName h
+
 	go desc a = property (desc ++ " " ++ cn) $ do
 		hn <- asks hostName
 		let cid = ContainerId hn cn
-		ensureProperties [findContainer mhost cid cn $ a cid]
-		
-	mhost = findHostNoAlias hosts (cn2hn cn)
+		ensureProperties [a cid (mkContainerInfo cid ctr)]
 
-	setup cid (Container image runparams) =
+	setup cid (ContainerInfo image runparams) =
 		provisionContainer cid
 			`requires`
 		runningContainer cid image runparams
 			`requires`
 		installed
 
-	teardown cid (Container image _runparams) =
+	teardown cid (ContainerInfo image _runparams) =
 		combineProperties ("undocked " ++ fromContainerId cid)
 			[ stoppedContainer cid
 			, property ("cleaned up " ++ fromContainerId cid) $
@@ -127,33 +131,21 @@ docked hosts cn = 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)
 
-findContainer
-	:: Maybe Host
-	-> ContainerId
-	-> ContainerName
-	-> (Container -> Property)
-	-> Property
-findContainer mhost cid cn mk = case mhost of
-	Nothing -> cantfind
-	Just h -> maybe cantfind mk (mkContainer cid h)
-  where
-	cantfind = containerDesc cid $ property "" $ do
-		liftIO $ warningMessage $
-			"missing definition for docker container \"" ++ cn2hn cn
-		return FailedChange
-
-mkContainer :: ContainerId -> Host -> Maybe Container
-mkContainer cid@(ContainerId hn _cn) h = Container
-	<$> fromVal (_dockerImage info)
-	<*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info))
+mkContainerInfo :: ContainerId -> Container -> ContainerInfo
+mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = 
+	ContainerInfo img runparams
   where
+	runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
+		(_dockerRunParams info)
 	info = _dockerinfo $ hostInfo h'
 	h' = h
 		-- Restart by default so container comes up on
@@ -207,7 +199,7 @@ memoryLimited = "/etc/default/grub" `File.containsLine` cfg
 	cmdline = "cgroup_enable=memory swapaccount=1"
 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
 
-data Container = Container Image [RunParam]
+data ContainerInfo = ContainerInfo Image [RunParam]
 
 -- | Parameters to pass to `docker run` when creating a container.
 type RunParam = String
@@ -301,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
@@ -324,22 +319,19 @@ toContainerId s
 fromContainerId :: ContainerId -> String
 fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
 
-containerHostName :: ContainerId -> HostName
-containerHostName (ContainerId _ cn) = cn2hn cn
-
 myContainerSuffix :: String
 myContainerSuffix = ".propellor"
 
 containerDesc :: ContainerId -> Property -> Property
 containerDesc cid p = p `describe` desc
   where
-	desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
+	desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
 
 runningContainer :: ContainerId -> Image -> [RunParam] -> Property
 runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
 	l <- liftIO $ listContainers RunningContainers
 	if cid `elem` l
-		then checkident =<< liftIO (getrunningident simpleShClient)
+		then checkident =<< liftIO getrunningident
 		else ifM (liftIO $ elem cid <$> listContainers AllContainers)
 			( do
 				-- The container exists, but is not
@@ -348,9 +340,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 				-- starting it up first.
 				void $ liftIO $ startContainer cid
 				-- It can take a while for the container to
-				-- start up enough to get its ident, so
-				-- retry for up to 60 seconds.
-				checkident =<< liftIO (getrunningident (simpleShClientRetry 60))
+				-- start up enough for its ident file to be
+				-- written, so retry for up to 60 seconds.
+				checkident =<< liftIO (retry 60 $ getrunningident)
 			, go image
 			)
   where
@@ -370,12 +362,18 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 		void $ liftIO $ removeContainer cid
 		go oldimage
 
-	getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
-		let !v = extractident rs
-		return v
+	getrunningident = readish
+		<$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent])
 
-	extractident :: [Resp] -> Maybe ContainerIdent
-	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
+	retry :: Int -> IO (Maybe a) -> IO (Maybe a)
+	retry 0 _ = return Nothing
+	retry n a = do
+		v <- a
+		case v of
+			Just _ -> return v
+			Nothing -> do
+				threadDelaySeconds (Seconds 1)				
+				retry (n-1) a
 
 	go img = do
 		liftIO $ do
@@ -385,7 +383,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 		liftIO $ writeFile (identFile cid) (show ident)
 		ensureProperty $ boolProperty "run" $ runContainer img
 			(runps ++ ["-i", "-d", "-t"])
-			[shim, "--continue", show (Docker (fromContainerId cid))]
+			[shim, "--continue", show (DockerInit (fromContainerId cid))]
 
 -- | Called when propellor is running inside a docker container.
 -- The string should be the container's ContainerId.
@@ -393,7 +391,6 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 -- This process is effectively init inside the container.
 -- It even needs to wait on zombie processes!
 --
--- Fork a thread to run the SimpleSh server in the background.
 -- In the foreground, run an interactive bash (or sh) shell,
 -- so that the user can interact with it when attached to the container.
 --
@@ -401,25 +398,22 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 -- again. So, to make the necessary services get started on boot, this needs
 -- to provision the container then. However, if the container is already
 -- being provisioned by the calling propellor, it would be redundant and
--- problimatic to also provisoon it here.
+-- problimatic to also provisoon it here, when not booting up.
 --
 -- The solution is a flag file. If the flag file exists, then the container
 -- was already provisioned. So, it must be a reboot, and time to provision
 -- again. If the flag file doesn't exist, don't provision here.
-chain :: String -> IO ()
-chain s = case toContainerId s of
+init :: String -> IO ()
+init s = case toContainerId s of
 	Nothing -> error $ "Invalid ContainerId: " ++ s
 	Just cid -> do
 		changeWorkingDirectory localdir
 		writeFile propellorIdent . show =<< readIdentFile cid
-		-- Run boot provisioning before starting simpleSh,
-		-- to avoid ever provisioning twice at the same time.
 		whenM (checkProvisionedFlag cid) $ do
 			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
-			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid) False]) $
+			unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $
 				warningMessage "Boot provision failed!"
 		void $ async $ job reapzombies
-		void $ async $ job $ simpleSh $ namedPipe cid
 		job $ do
 			void $ tryIO $ ifM (inPath "bash")
 				( boolSystem "bash" [Param "-l"]
@@ -432,36 +426,47 @@ chain s = case toContainerId s of
 
 -- | Once a container is running, propellor can be run inside
 -- it to provision it.
---
--- Note that there is a race here, between the simplesh
--- server starting up in the container, and this property
--- being run. So, retry connections to the client for up to
--- 1 minute.
 provisionContainer :: ContainerId -> Property
 provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+	let params = ["--continue", show $ toChain cid]
 	msgh <- mkMessageHandle
-	let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)]
-	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
+	let p = inContainerProcess cid
+		[ if isConsole msgh then "-it" else "-i" ]
+		(shim : params)
+	r <- withHandle StdoutHandle createProcessSuccess p $
+		processoutput Nothing
 	when (r /= FailedChange) $
 		setProvisionedFlag cid 
 	return r
   where
-	go lastline (v:rest) = case v of
-		StdoutLine s -> do
-			maybe noop putStrLn lastline
-			hFlush stdout
-			go (Just s) rest
-		StderrLine s -> do
-			maybe noop putStrLn lastline
-			hFlush stdout
-			hPutStrLn stderr s
-			hFlush stderr
-			go Nothing rest
-		Done -> ret lastline
-	go lastline [] = ret lastline
+	processoutput lastline h = do
+		v <- catchMaybeIO (hGetLine h)
+		case v of
+			Nothing -> pure $ fromMaybe FailedChange $
+				readish =<< lastline
+			Just s -> do
+				maybe noop putStrLn lastline
+				hFlush stdout
+				processoutput (Just s) h
+
+toChain :: ContainerId -> CmdLine
+toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
 
-	ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
+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
 
 stopContainer :: ContainerId -> IO Bool
 stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
@@ -479,7 +484,6 @@ stoppedContainer cid = containerDesc cid $ property desc $
   where
 	desc = "stopped"
 	cleanup = do
-		nukeFile $ namedPipe cid
 		nukeFile $ identFile cid
 		removeDirectoryRecursive $ shimdir cid
 		clearProvisionedFlag cid
@@ -496,6 +500,9 @@ runContainer :: Image -> [RunParam] -> [String] -> IO Bool
 runContainer image ps cmd = boolSystem dockercmd $ map Param $
 	"run" : (ps ++ image : cmd)
 
+inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
+inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
+
 commitContainer :: ContainerId -> IO (Maybe Image)
 commitContainer cid = catchMaybeIO $
 	takeWhile (/= '\n') 
@@ -521,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 }
@@ -538,10 +545,6 @@ dockerInfo i = mempty { _dockerinfo = i }
 propellorIdent :: FilePath
 propellorIdent = "/.propellor-ident"
 
--- | Named pipe used for communication with the container.
-namedPipe :: ContainerId -> FilePath
-namedPipe cid = "docker" </> fromContainerId cid
-
 provisionedFlag :: ContainerId -> FilePath
 provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
 
@@ -556,6 +559,9 @@ setProvisionedFlag cid = do
 checkProvisionedFlag :: ContainerId -> IO Bool
 checkProvisionedFlag = doesFileExist . provisionedFlag
 
+provisioningLock :: ContainerId -> FilePath
+provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock"
+
 shimdir :: ContainerId -> FilePath
 shimdir cid = "docker" </> fromContainerId cid ++ ".shim"