Merge branch 'joeyconfig'

Conflicts:
	config.hs

4 files changed, 114 insertions, 22 deletions

diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index 5f819f26..888e76c6 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -4,13 +4,6 @@
 --
 -- The existance of a docker container is just another Property of a system,
 -- which propellor can set up. See config.hs for an example.
---
--- Note that propellor provisions a container by running itself, inside the
--- container. Currently, to avoid the overhead of building propellor
--- inside the container, the binary from outside is reused inside. 
--- So, the libraries that propellor is linked against need to be available
--- in the container with compatable versions. This can cause a problem
--- if eg, mixing Debian stable and unstable.
 
 module Propellor.Property.Docker where
 
@@ -18,6 +11,7 @@ import Propellor
 import Propellor.SimpleSh
 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
 
@@ -256,15 +250,14 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 		, name (fromContainerId cid)
 		]
 	
-	chaincmd = [localdir </> "propellor", "--docker", fromContainerId cid]
-
 	go img = do
 		clearProvisionedFlag cid
 		createDirectoryIfMissing True (takeDirectory $ identFile cid)
+		shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
 		writeFile (identFile cid) (show ident)
 		ensureProperty $ boolProperty "run" $ runContainer img
 			(runps ++ ["-i", "-d", "-t"])
-			chaincmd
+			[shim, "--docker", fromContainerId cid]
 
 -- | Called when propellor is running inside a docker container.
 -- The string should be the container's ContainerId.
@@ -290,8 +283,9 @@ chain s = case toContainerId s of
 		writeFile propellorIdent . show =<< readIdentFile cid
 		-- Run boot provisioning before starting simpleSh,
 		-- to avoid ever provisioning twice at the same time.
-		whenM (checkProvisionedFlag cid) $
-			unlessM (boolSystem "./propellor" [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
+		whenM (checkProvisionedFlag cid) $ do
+			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
 				warningMessage "Boot provision failed!"
 		void $ async $ simpleSh $ namedPipe cid
 		forever $ do
@@ -310,7 +304,8 @@ chain s = case toContainerId s of
 -- 1 minute.
 provisionContainer :: ContainerId -> Property
 provisionContainer cid = containerDesc cid $ Property "provision" $ do
-	r <- simpleShClientRetry 60 (namedPipe cid) "./propellor" params (go Nothing)
+	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
 	when (r /= FailedChange) $
 		setProvisionedFlag cid 
 	return r
@@ -342,11 +337,17 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
 stoppedContainer :: ContainerId -> Property
 stoppedContainer cid = containerDesc cid $ Property desc $ 
 	ifM (elem cid <$> listContainers RunningContainers)
-		( ensureProperty $ boolProperty desc $ stopContainer cid
+		( cleanup `after` ensureProperty 
+			(boolProperty desc $ stopContainer cid)
 		, return NoChange
 		)
   where
 	desc = "stopped"
+	cleanup = do
+		nukeFile $ namedPipe cid
+		nukeFile $ identFile cid
+		removeDirectoryRecursive $ shimdir cid
+		clearProvisionedFlag cid
 
 removeContainer :: ContainerId -> IO Bool
 removeContainer cid = catchBoolIO $
@@ -396,10 +397,10 @@ propellorIdent = "/.propellor-ident"
 
 -- | Named pipe used for communication with the container.
 namedPipe :: ContainerId -> FilePath
-namedPipe cid = "docker/" ++ fromContainerId cid
+namedPipe cid = "docker" </> fromContainerId cid
 
 provisionedFlag :: ContainerId -> FilePath
-provisionedFlag cid = "docker/" ++ fromContainerId cid ++ ".provisioned"
+provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
 
 clearProvisionedFlag :: ContainerId -> IO ()
 clearProvisionedFlag = nukeFile . provisionedFlag
@@ -412,8 +413,11 @@ setProvisionedFlag cid = do
 checkProvisionedFlag :: ContainerId -> IO Bool
 checkProvisionedFlag = doesFileExist . provisionedFlag
 
+shimdir :: ContainerId -> FilePath
+shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
+
 identFile :: ContainerId -> FilePath
-identFile cid = "docker/" ++ fromContainerId cid ++ ".ident"
+identFile cid = "docker" </> fromContainerId cid ++ ".ident"
 
 readIdentFile :: ContainerId -> IO ContainerIdent
 readIdentFile cid = fromMaybe (error "bad ident in identFile")
diff --git a/Propellor/Property/Docker/Shim.hs b/Propellor/Property/Docker/Shim.hs
new file mode 100644
index 00000000..01c2b22f
--- /dev/null
+++ b/Propellor/Property/Docker/Shim.hs
@@ -0,0 +1,58 @@
+-- | Support for running propellor, as built outside a docker container,
+-- inside the container.
+--
+-- Note: This is currently Debian specific, due to glibcLibs.
+
+module Propellor.Property.Docker.Shim (setup, file) where
+
+import Propellor
+import Utility.LinuxMkLibs
+import Utility.SafeCommand
+import Utility.Path
+import Utility.FileMode
+
+import Data.List
+import System.Posix.Files
+
+-- | Sets up a shimmed version of the program, in a directory, and
+-- returns its path.
+setup :: FilePath -> FilePath -> IO FilePath
+setup propellorbin dest = do
+	createDirectoryIfMissing True dest
+
+	libs <- parseLdd <$> readProcess "ldd" [propellorbin]
+	glibclibs <- glibcLibs
+	let libs' = nub $ libs ++ glibclibs
+	libdirs <- map (dest ++) . nub . catMaybes
+		<$> mapM (installLib installFile dest) libs'
+	
+	let linker = (dest ++) $ 
+		fromMaybe (error "cannot find ld-linux linker") $
+			headMaybe $ filter ("ld-linux" `isInfixOf`) libs'
+	let gconvdir = (dest ++) $ parentDir $
+		fromMaybe (error "cannot find gconv directory") $
+			headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs
+	let linkerparams = ["--library-path", intercalate ":" libdirs ]
+	let shim = file propellorbin dest
+	writeFile shim $ unlines
+		[ "#!/bin/sh"
+		, "GCONV_PATH=" ++ shellEscape gconvdir
+		, "export GCONV_PATH"
+		, "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ 
+			" " ++ shellEscape propellorbin ++ " \"$@\""
+		]
+	modifyFileMode shim (addModes executeModes)
+	return shim
+
+file :: FilePath -> FilePath -> FilePath
+file propellorbin dest = dest </> takeFileName propellorbin
+
+installFile :: FilePath -> FilePath -> IO ()
+installFile top f = do
+	createDirectoryIfMissing True destdir
+	nukeFile dest
+	createLink f dest `catchIO` (const copy)
+  where
+	copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]
+	destdir = inTop top $ parentDir f
+	dest = inTop top f
diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs
index af4f554f..80c69d9b 100644
--- a/Propellor/Property/File.hs
+++ b/Propellor/Property/File.hs
@@ -2,6 +2,8 @@ module Propellor.Property.File where
 
 import Propellor
 
+import System.Posix.Files
+
 type Line = String
 
 -- | Replaces all the content of a file.
@@ -32,13 +34,19 @@ fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
 fileProperty desc a f = Property desc $ go =<< doesFileExist f
   where
 	go True = do
-		ls <- lines <$> catchDefaultIO [] (readFile f)
+		ls <- lines <$> readFile f
 		let ls' = a ls
 		if ls' == ls
 			then noChange
-			else makeChange $ viaTmp writeFile f (unlines ls')
+			else makeChange $ viaTmp updatefile f (unlines ls')
 	go False = makeChange $ writeFile f (unlines $ a [])
 
+	-- viaTmp makes the temp file mode 600.
+	-- Replicate the original file mode before moving it into place.
+	updatefile f' content = do
+		writeFile f' content
+		getFileStatus f >>= setFileMode f' . fileMode
+
 -- | Ensures a directory exists.
 dirExists :: FilePath -> Property
 dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
index 25f0e1b2..26635374 100644
--- a/Propellor/Property/Hostname.hs
+++ b/Propellor/Property/Hostname.hs
@@ -3,7 +3,29 @@ module Propellor.Property.Hostname where
 import Propellor
 import qualified Propellor.Property.File as File
 
+-- | Sets the hostname. Configures both /etc/hostname and the current
+-- hostname.
+--
+-- When provided with a FQDN, also configures /etc/hosts,
+-- with an entry for 127.0.1.1, which is standard at least on Debian
+-- to set the FDQN (127.0.0.1 is localhost).
 set :: HostName -> Property
-set hostname = "/etc/hostname" `File.hasContent` [hostname]
-	`onChange` cmdProperty "hostname" [hostname]
-	`describe` ("hostname " ++ hostname)
+set hostname = combineProperties desc go
+	`onChange` cmdProperty "hostname" [host]
+  where
+	desc = "hostname " ++ hostname
+	(host, domain) = separate (== '.') hostname
+
+	go = catMaybes
+		[ Just $ "/etc/hostname" `File.hasContent` [host]
+		, if null domain
+			then Nothing 
+			else Just $ File.fileProperty desc
+				addhostline "/etc/hosts"
+		]
+	
+	hostip = "127.0.1.1"
+	hostline = hostip ++ "\t" ++ hostname ++ " " ++ host
+
+	addhostline ls = hostline : filter (not . hashostip) ls
+	hashostip l = headMaybe (words l) == Just hostip