Merge branch 'joeyconfig'

Conflicts:
	config.hs

.gitignore

@@ -6,3 +6,4 @@ privdata/keyring.gpg~
 Setup
 Setup.hi
 Setup.o
+docker

Propellor/Config/Joey.hs

@@ -10,13 +10,15 @@ import qualified Propellor.Property.Cron as Cron
 import qualified Propellor.Property.Sudo as Sudo
 import qualified Propellor.Property.User as User
 import qualified Propellor.Property.Hostname as Hostname
-import qualified Propellor.Property.Reboot as Reboot
+--import qualified Propellor.Property.Reboot as Reboot
 import qualified Propellor.Property.Tor as Tor
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
 import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
 import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
 import Data.List
+-- Only imported to make sure it continues to build.
+import qualified ConfigSimple as Simple
 
 main :: IO ()
 main = defaultMain [host, Docker.containerProperties container]
@@ -45,7 +47,7 @@ host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
 	& Docker.configured
 	& Apt.buildDep ["git-annex"]
 	& Docker.docked container hostname "amd64-git-annex-builder"
-	! Docker.docked container hostname "i386-git-annex-builder"
+	& Docker.docked container hostname "i386-git-annex-builder"
 	& Docker.garbageCollected
 -- My laptop
 host _hostname@"darkstar.kitenet.net" = Just $ props
@@ -75,17 +77,14 @@ container _host name
 	| otherwise = Nothing
 
 -- | Docker images I prefer to use.
--- Edit as suites you, or delete this function and just put the image names
--- above.
 image :: System -> Docker.Image
-image (System (Debian Unstable) "amd64") = "joeyh/debian-unstable"
-image (System (Debian Unstable) "i386") = "joeyh/debian-unstable-i386"
-image _ = "debian"
+image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
+image _ = "debian-stable-official" -- does not currently exist!
 
 -- This is my standard system setup
 standardSystem :: DebianSuite -> [Property] -> Maybe [Property]
 standardSystem suite customprops = Just $
-	standardprops : customprops ++ [endprops]
+	standardprops : customprops ++ endprops
   where
 	standardprops = propertyList "standard system" $ props
 		& Apt.stdSourcesList suite `onChange` Apt.upgrade
@@ -104,9 +103,11 @@ standardSystem suite customprops = Just $
 		& Apt.installed ["vim", "screen", "less"]
 		& Cron.runPropellor "30 * * * *"
 		-- I use postfix, or no MTA.
-		& Apt.removed ["exim4"] `onChange` Apt.autoRemove
-	-- May reboot, so comes last.
-	endprops = Apt.installed ["systemd-sysv"] `onChange` Reboot.now
+		& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
+			`onChange` Apt.autoRemove
+	-- May reboot, so comes last
+	-- Currently not enable due to #726375 
+	endprops = [] -- [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]
 
 -- Clean up a system as installed by cloudatcost.com
 cleanCloudAtCost :: HostName -> Property

Propellor/Message.hs

@@ -15,21 +15,25 @@ actionMessage desc a = do
 
 	r <- a
 
+	setTitle "propellor: running"
 	let (msg, intensity, color) = getActionResult r
 	putStr $ desc ++ " ... "
-	setSGR [SetColor Foreground intensity color]
-	putStrLn msg
-	setSGR []
-	setTitle "propellor: running"
+	colorLine intensity color msg
 	hFlush stdout
 
 	return r
 
 warningMessage :: String -> IO ()
-warningMessage s = do
-	setSGR [SetColor Foreground Vivid Red]
-	putStrLn $ "** warning: " ++ s
+warningMessage s = colorLine Vivid Red $ "** warning: " ++ s
+
+colorLine :: ColorIntensity -> Color -> String -> IO ()
+colorLine intensity color msg = do
+	setSGR [SetColor Foreground intensity color]
+	putStr msg
 	setSGR []
+	-- Note this comes after the color is reset, so that
+	-- the color set and reset happen in the same line.
+	putStrLn ""
 	hFlush stdout
 
 errorMessage :: String -> IO a

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

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

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

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

TODO

@@ -12,3 +12,5 @@
   says they are unchanged even when they changed and triggered a
   reprovision.
 * Should properties be a tree rather than a list?
+* Only make docker garbage collection run once a day or something
+  to avoid GC after a temp fail.

Utility/LinuxMkLibs.hs

@@ -0,0 +1,61 @@
+{- Linux library copier and binary shimmer
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.LinuxMkLibs where
+
+import Control.Applicative
+import Data.Maybe
+import System.Directory
+import Data.List.Utils
+import System.Posix.Files
+import Data.Char
+import Control.Monad.IfElse
+
+import Utility.PartialPrelude
+import Utility.Directory
+import Utility.Process
+import Utility.Monad
+import Utility.Path
+
+{- Installs a library. If the library is a symlink to another file,
+ - install the file it links to, and update the symlink to be relative. -}
+installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
+installLib installfile top lib = ifM (doesFileExist lib)
+	( do
+		installfile top lib
+		checksymlink lib
+		return $ Just $ parentDir lib
+	, return Nothing
+	)
+  where
+	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
+		l <- readSymbolicLink (inTop top f)
+		let absl = absPathFrom (parentDir f) l
+		let target = relPathDirToFile (parentDir f) absl
+		installfile top absl
+		nukeFile (top ++ f)
+		createSymbolicLink target (inTop top f)
+		checksymlink absl
+
+-- Note that f is not relative, so cannot use </>
+inTop :: FilePath -> FilePath -> FilePath
+inTop top f = top ++ f
+
+{- Parse ldd output, getting all the libraries that the input files
+ - link to. Note that some of the libraries may not exist 
+ - (eg, linux-vdso.so) -}
+parseLdd :: String -> [FilePath]
+parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines
+  where
+	getlib l = headMaybe . words =<< lastMaybe (split " => " l)
+
+{- Get all glibc libs and other support files, including gconv files
+ -
+ - XXX Debian specific. -}
+glibcLibs :: IO [FilePath]
+glibcLibs = lines <$> readProcess "sh"
+	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]

config.hs

@@ -1 +1 @@
-config-simple.hs
+Propellor/Config/Simple.hs

debian/changelog

@@ -1,3 +1,12 @@
+propellor (0.2.2) unstable; urgency=medium
+
+  * Now supports provisioning docker containers with architecture/libraries
+    that do not match the host.
+  * Fixed a bug that caused file modes to be set to 600 when propellor
+    modified the file (did not affect newly created files).
+
+ -- Joey Hess <joeyh@debian.org>  Fri, 04 Apr 2014 01:07:32 -0400
+
 propellor (0.2.1) unstable; urgency=medium
 
   * First release with Debian package.

propellor.cabal

@@ -1,5 +1,5 @@
 Name: propellor
-Version: 0.2.1
+Version: 0.2.2
 Cabal-Version: >= 1.6
 License: GPL
 Maintainer: Joey Hess <joey@kitenet.net>
@@ -14,8 +14,6 @@ Extra-Source-Files:
   README.md
   TODO
   CHANGELOG
-  config-simple.hs
-  config-joeyh.hs
   Makefile
   debian/changelog
   debian/README.Debian
@@ -64,6 +62,8 @@ Library
 
   Exposed-Modules:
     Propellor
+    Propellor.Config.Simple
+    Propellor.Config.Joey
     Propellor.Property
     Propellor.Property.Apt
     Propellor.Property.Cmd
@@ -87,6 +87,7 @@ Library
   Other-Modules:
     Propellor.CmdLine
     Propellor.SimpleSh
+    Propellor.Property.Docker.Shim
     Utility.Applicative
     Utility.Data
     Utility.Directory
@@ -94,6 +95,7 @@ Library
     Utility.Exception
     Utility.FileMode
     Utility.FileSystemEncoding
+    Utility.LinuxMkLibs
     Utility.Misc
     Utility.Monad
     Utility.Path