Merge branch 'joeyconfig'

5 files changed, 188 insertions, 72 deletions

diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 4b3f2da2..baf36e49 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -1,4 +1,8 @@
 module Propellor.Bootstrap (
+	Bootstrapper(..),
+	Builder(..),
+	defaultBootstrapper,
+	getBootstrapper,
 	bootstrapPropellorCommand,
 	checkBinaryCommand,
 	installGitCommand,
@@ -16,71 +20,120 @@ import Data.List
 
 type ShellCommand = String
 
+-- | Different ways that Propellor's dependencies can be installed,
+-- and propellor can be built. The default is `Robustly Cabal`
+--
+-- `Robustly Cabal` and `Robustly Stack` use the OS's native packages
+-- as much as possible to install Cabal, Stack, and propellor's build
+-- dependencies. When necessary, dependencies are built from source
+-- using Cabal or Stack rather than using the OS's native packages.
+--
+-- `OSOnly` uses the OS's native packages of Cabal and all of propellor's
+-- build dependencies. It may not work on all systems.
+data Bootstrapper = Robustly Builder | OSOnly
+	deriving (Show)
+
+data Builder = Cabal | Stack
+	deriving (Show)
+
+defaultBootstrapper :: Bootstrapper
+defaultBootstrapper = Robustly Cabal
+
+-- | Gets the Bootstrapper for the Host propellor is running on.
+getBootstrapper :: Propellor Bootstrapper
+getBootstrapper = go <$> askInfo
+  where
+	go NoInfoVal = defaultBootstrapper
+	go (InfoVal bs) = bs
+
+getBuilder :: Bootstrapper -> Builder
+getBuilder (Robustly b) = b
+getBuilder OSOnly = Cabal
+
 -- Shell command line to ensure propellor is bootstrapped and ready to run.
 -- Should be run inside the propellor config dir, and will install
 -- all necessary build dependencies and build propellor.
-bootstrapPropellorCommand :: Maybe System -> ShellCommand
-bootstrapPropellorCommand msys = checkDepsCommand msys ++
+bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> ShellCommand
+bootstrapPropellorCommand bs msys = checkDepsCommand bs msys ++
 	"&& if ! test -x ./propellor; then "
-		++ buildCommand ++
-	"; fi;" ++ checkBinaryCommand
+		++ buildCommand bs ++
+	"; fi;" ++ checkBinaryCommand bs
 
 -- Use propellor --check to detect if the local propellor binary has
 -- stopped working (eg due to library changes), and must be rebuilt.
-checkBinaryCommand :: ShellCommand
-checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi"
+checkBinaryCommand :: Bootstrapper -> ShellCommand
+checkBinaryCommand bs = "if test -x ./propellor && ! ./propellor --check; then " ++ go (getBuilder bs) ++ "; fi"
   where
-	go = intercalate " && "
+	go Cabal = intercalate " && "
 		[ "cabal clean"
-		, buildCommand
+		, buildCommand bs
+		]
+	go Stack = intercalate " && "
+		[ "stack clean"
+		, buildCommand bs
 		]
 
-buildCommand :: ShellCommand
-buildCommand = intercalate " && "
-	[ "cabal configure"
-	, "cabal build propellor-config"
-	, "ln -sf dist/build/propellor-config/propellor-config propellor"
-	]
+buildCommand :: Bootstrapper -> ShellCommand
+buildCommand bs = intercalate " && " (go (getBuilder bs))
+  where
+	go Cabal =
+		[ "cabal configure"
+		, "cabal build propellor-config"
+		, "ln -sf dist/build/propellor-config/propellor-config propellor"
+		]
+	go Stack =
+		[ "stack build :propellor-config"
+		, "ln -sf $(stack path --dist-dir)/build/propellor-config propellor"
+		]
 
 -- Run cabal configure to check if all dependencies are installed;
 -- if not, run the depsCommand.
-checkDepsCommand :: Maybe System -> ShellCommand
-checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi"
+checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand
+checkDepsCommand bs sys = go (getBuilder bs)
+  where
+	go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
+	go Stack = "if ! stack --version >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
 
--- Install build dependencies of propellor.
---
--- First, try to install ghc, cabal, gnupg, and all haskell libraries that
--- propellor uses from OS packages.
+-- Install build dependencies of propellor, using the specified
+-- Bootstrapper.
 --
+-- When bootstrapping Robustly, first try to install the builder, 
+-- and all haskell libraries that propellor uses from OS packages.
 -- Some packages may not be available in some versions of Debian
 -- (eg, Debian wheezy lacks async), or propellor may need a newer version.
--- So, as a second step, cabal is used to install all dependencies.
+-- So, as a second step, any other dependencies are installed from source
+-- using the builder.
 --
 -- Note: May succeed and leave some deps not installed.
-depsCommand :: Maybe System -> ShellCommand
-depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true"
+depsCommand :: Bootstrapper -> Maybe System -> ShellCommand
+depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true"
   where
-	osinstall = case msys of
-		Just (System (FreeBSD _) _) -> map pkginstall fbsddeps
-		Just (System (ArchLinux) _) -> map pacmaninstall archlinuxdeps
-		Just (System (Debian _ _) _) -> useapt
-		Just (System (Buntish _) _) -> useapt
-		-- assume a debian derived system when not specified
-		Nothing -> useapt
-
-	useapt = "apt-get update" : map aptinstall debdeps
-
-	cabalinstall =
+	go (Robustly Cabal) = osinstall Cabal ++
 		[ "cabal update"
 		, "cabal install --only-dependencies"
+		]	
+	go (Robustly Stack) = osinstall Stack ++ 
+		[ "stack setup"
+		, "stack build --only-dependencies :propellor-config"
 		]
+	go OSOnly = osinstall Cabal
+
+	osinstall builder = case msys of
+		Just (System (FreeBSD _) _) -> map pkginstall (fbsddeps builder)
+		Just (System (ArchLinux) _) -> map pacmaninstall (archlinuxdeps builder)
+		Just (System (Debian _ _) _) -> useapt builder
+		Just (System (Buntish _) _) -> useapt builder
+		-- assume a Debian derived system when not specified
+		Nothing -> useapt builder
+
+	useapt builder = "apt-get update" : map aptinstall (debdeps builder)
 
 	aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p
 	pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p
 	pacmaninstall p = "pacman -S --noconfirm --needed " ++ p
 
 	-- This is the same deps listed in debian/control.
-	debdeps =
+	debdeps Cabal =
 		[ "gnupg"
 		, "ghc"
 		, "cabal-install"
@@ -98,7 +151,12 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
 		, "libghc-text-dev"
 		, "libghc-hashable-dev"
 		]
-	fbsddeps =
+	debdeps Stack =
+		[ "gnupg"
+		, "haskell-stack"
+		]
+
+	fbsddeps Cabal =
 		[ "gnupg"
 		, "ghc"
 		, "hs-cabal-install"
@@ -116,7 +174,12 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
 		, "hs-text"
 		, "hs-hashable"
 		]
-	archlinuxdeps =
+	fbsddeps Stack =
+		[ "gnupg"
+		, "stack"
+		]
+
+	archlinuxdeps Cabal =
 		[ "gnupg"
 		, "ghc"
 		, "cabal-install"
@@ -135,6 +198,10 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
 		, "haskell-text"
 		, "hashell-hashable"
 		]
+	archlinuxdeps Stack = 
+		[ "gnupg"
+		, "stack"
+		]
 
 installGitCommand :: Maybe System -> ShellCommand
 installGitCommand msys = case msys of
@@ -155,22 +222,28 @@ installGitCommand msys = case msys of
 		, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
 		]
 
+-- Build propellor, and symlink the built binary to ./propellor.
+--
+-- When the Host has a Buildsystem specified it is used. If none is
+-- specified, look at git config propellor.buildsystem.
 buildPropellor :: Maybe Host -> IO ()
-buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $
+buildPropellor mh = unlessM (actionMessage "Propellor build" build) $
 	errorMessage "Propellor build failed!"
   where
 	msys = case fmap (fromInfo . hostInfo) mh of
 		Just (InfoVal sys) -> Just sys
 		_ -> Nothing
 
--- Build propellor using cabal or stack, and symlink propellor to the
--- built binary.
-build :: Maybe System -> IO Bool
-build msys = catchBoolIO $ do
-	bs <- getGitConfigValue "propellor.buildsystem"
-	case bs of
-		Just "stack" -> stackBuild msys
-		_ -> cabalBuild msys
+	build = catchBoolIO $ do
+		case fromInfo (maybe mempty hostInfo mh) of
+			NoInfoVal -> do			
+				bs <- getGitConfigValue "propellor.buildsystem"
+				case bs of
+					Just "stack" -> stackBuild msys
+					_ -> cabalBuild msys
+			InfoVal bs -> case getBuilder bs of
+				Cabal -> cabalBuild msys
+				Stack -> stackBuild msys
 
 -- For speed, only runs cabal configure when it's not been run before.
 -- If the build fails cabal may need to have configure re-run.
@@ -203,7 +276,7 @@ cabalBuild msys = do
 		, case msys of
 			Nothing -> return False
 			Just sys ->
-				boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))]
+				boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))]
 					<&&> cabal ["configure"]
 		)
 	cabal_build = cabal ["build", "propellor-config"]
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
index 767d6ef7..93529c14 100644
--- a/src/Propellor/Property/Bootstrap.hs
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -1,12 +1,39 @@
-module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where
+-- | This module contains properties that configure how Propellor
+-- bootstraps to run itself on a Host.
+
+module Propellor.Property.Bootstrap (
+	Bootstrapper(..),
+	bootstrapWith,
+	RepoSource(..),
+	bootstrappedFrom,
+	clonedFrom
+) where
 
 import Propellor.Base
 import Propellor.Bootstrap
+import Propellor.Types.Info
 import Propellor.Property.Chroot
 
 import Data.List
 import qualified Data.ByteString as B
 
+-- | This property can be used to configure the `Bootstrapper` that is used
+-- to bootstrap propellor on a Host. For example, if you want to use
+-- stack:
+--
+-- > host "example.com" $ props
+-- > 	& bootstrapWith (Robustly Stack)
+--
+-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`, 
+-- this property can also be added to the chroot to configure it.
+bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
+bootstrapWith b = pureInfoProperty desc (InfoVal b)
+  where
+	desc = "bootstrapped with " ++ case b of
+		Robustly Stack -> "stack"
+		Robustly Cabal -> "cabal"
+		OSOnly -> "OS packages only"
+
 -- | Where a propellor repository should be bootstrapped from.
 data RepoSource
 	= GitRepoUrl String
@@ -17,14 +44,17 @@ data RepoSource
 -- | Bootstraps a propellor installation into
 -- /usr/local/propellor/
 --
--- This property only does anything when used inside a chroot.
--- This is particularly useful inside a chroot used to build a
+-- Normally, propellor is bootstrapped by eg, using propellor --spin,
+-- and so this property is not generally needed.
+--
+-- This property only does anything when used inside a Chroot or other
+-- Container. This is particularly useful inside a chroot used to build a
 -- disk image, to make the disk image have propellor installed.
 --
 -- The git repository is cloned (or pulled to update if it already exists).
 --
 -- All build dependencies are installed, using distribution packages
--- or falling back to using cabal.
+-- or falling back to using cabal or stack.
 bootstrappedFrom :: RepoSource -> Property Linux
 bootstrappedFrom reposource = check inChroot $
 	go `requires` clonedFrom reposource
@@ -32,14 +62,15 @@ bootstrappedFrom reposource = check inChroot $
 	go :: Property Linux
 	go = property "Propellor bootstrapped" $ do
 		system <- getOS
+		bootstrapper <- getBootstrapper
 		assumeChange $ exposeTrueLocaldir $ const $ 
 			runShellCommand $ buildShellCommand
 				[ "cd " ++ localdir
-				, checkDepsCommand system
-				, buildCommand
+				, checkDepsCommand bootstrapper system
+				, buildCommand bootstrapper
 				]
 
--- | Clones the propellor repeository into /usr/local/propellor/
+-- | Clones the propellor repository into /usr/local/propellor/
 --
 -- If the propellor repo has already been cloned, pulls to get it
 -- up-to-date.
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 0966a7e5..ab700a9d 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -80,7 +80,8 @@ niceJob desc times user cddir command = job desc times user cddir
 
 -- | Installs a cron job to run propellor.
 runPropellor :: Times -> Property UnixLike
-runPropellor times = withOS "propellor cron job" $ \w o -> 
+runPropellor times = withOS "propellor cron job" $ \w o -> do
+	bootstrapper <- getBootstrapper
 	ensureProperty w $
 		niceJob "propellor" times (User "root") localdir
-			(bootstrapPropellorCommand o ++ "; ./propellor")
+			(bootstrapPropellorCommand bootstrapper o ++ "; ./propellor")
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index ae7e0404..e90155f3 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -53,11 +53,7 @@ sendMarked' h marker s = do
 	hFlush h
 
 getMarked :: Handle -> Marker -> IO (Maybe String)
-getMarked h marker = do
-	-- Avoid buffering anything in Handle, so that the data after
-	-- the marker will be available to be read from the underlying Fd.
-	hSetBuffering stdin NoBuffering
-	go =<< catchMaybeIO (hGetLine h)
+getMarked h marker = go =<< catchMaybeIO (hGetLine h)
   where
 	go Nothing = return Nothing
 	go (Just l) = case fromMarked marker l of
@@ -69,8 +65,8 @@ getMarked h marker = do
 			debug ["received marked", marker]
 			return (Just v)
 
-reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()
-reqMarked stage marker a = do
+req :: Stage -> Marker -> (String -> IO ()) -> IO ()
+req stage marker a = do
 	debug ["requested marked", marker]
 	sendMarked' stdout statusMarker (show stage)
 	maybe noop a =<< getMarked stdin marker
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index cd964e16..aeaa4643 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -93,6 +93,9 @@ spin' mprivdata relay target hst = do
 	sys = case fromInfo (hostInfo hst) of
 		InfoVal o -> Just o
 		NoInfoVal -> Nothing
+	bootstrapper = case fromInfo (hostInfo hst) of
+		NoInfoVal -> defaultBootstrapper
+		InfoVal bs -> bs
 
 	relaying = relay == Just target
 	viarelay = isJust relay && not relaying
@@ -109,7 +112,7 @@ spin' mprivdata relay target hst = do
 
 	updatecmd = intercalate " && "
 		[ "cd " ++ localdir
-		, bootstrapPropellorCommand sys
+		, bootstrapPropellorCommand bootstrapper sys
 		, if viarelay
 			then "./propellor --continue " ++
 				shellEscape (show (Relay target))
@@ -178,11 +181,11 @@ getSshTarget target hst
 update :: Maybe HostName -> IO ()
 update forhost = do
 	whenM hasGitRepo $
-		reqMarked NeedRepoUrl repoUrlMarker setRepoUrl
+		req NeedRepoUrl repoUrlMarker setRepoUrl
 
 	makePrivDataDir
 	createDirectoryIfMissing True (takeDirectory privfile)
-	reqMarked NeedPrivData privDataMarker $
+	req NeedPrivData privDataMarker $
 		writeFileProtected privfile
 
 	whenM hasGitRepo $
@@ -350,18 +353,30 @@ spinCommitMessage = "propellor spin"
 -- Request that it run git upload-pack, and connect that up to a git fetch
 -- to receive the data.
 gitPullFromUpdateServer :: IO ()
-gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do
-	-- Note that this relies on data not being buffered in the stdin
-	-- Handle, since such buffered data would not be available in the
-	-- FD passed to git fetch. 
-	hin <- dup stdInput
+gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do
+	-- IO involving stdin can cause data to be buffered in the Handle
+	-- (even when it's set NoBuffering), but we need to pass a FD to 
+	-- git fetch containing all of stdin after the gitPushMarker,
+	-- including any that has been buffered.
+	--
+	-- To do so, create a pipe, and forward stdin, including any
+	-- buffered part, through it.
+	(pread, pwrite) <- System.Posix.IO.createPipe
+	-- Note that there is a race between the createPipe and setting
+	-- CloseOnExec. Another processess forked here would inherit
+	-- pwrite and perhaps keep it open. However, propellor is not
+	-- running concurrent threads at this point, so this is ok.
+	setFdOption pwrite CloseOnExec True
+	hwrite <- fdToHandle pwrite
+	forwarder <- async $ stdin *>* hwrite
+	let hin = pread
 	hout <- dup stdOutput
-	hClose stdin
 	hClose stdout
 	-- Not using git pull because git 2.5.0 badly
 	-- broke its option parser.
 	unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
 		errorMessage "git fetch from client failed"
+	wait forwarder
 	unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
 		errorMessage "git merge from client failed"
   where