Merge branch 'joeyconfig'

Makefile

@@ -8,8 +8,8 @@ run: deps build
 dev: build tags
 
 build: dist/setup-config
-	if ! $(CABAL) build; then $(CABAL) configure; $(CABAL) build; fi
+	@if ! $(CABAL) build; then $(CABAL) configure; $(CABAL) build; fi
-	ln -sf dist/build/propellor-config/propellor-config propellor
+	@ln -sf dist/build/propellor-config/propellor-config propellor
 
 deps:
 	@if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install $(DEBDEPS) || (apt-get update && apt-get --no-upgrade --no-install-recommends -y install $(DEBDEPS)); fi || true

doc/centralized_git_repository.mdwn

@@ -4,7 +4,13 @@ directly to the host. This makes it easy to get started with propellor.
 
 A central git repository allows hosts to run propellor from cron and pick
 up any updates you may have pushed. This is useful when managing several
-hosts with propellor.
+hosts with propellor. 
+
+The central repository does not need to be trusted; it can be hosted 
+anywhere, and propellor will only accept verified gpg signed git commits
+from it. See [[security]] for details, but this means you can put it
+on github without github being able to 0wn your propellor driven hosts, for
+example.
 
 You can add a central git repository to your existing propellor setup easily:
 

doc/security.mdwn

@@ -6,13 +6,13 @@ The only trusted machine is the laptop where you run `propellor --spin`
 to connect to a remote host. And that one only because you have a ssh key
 or login password to the host.
 
-Since the hosts propellor deploys are not trusted by the central git
+Since the hosts propellor deploys do not trust the central git repository,
-repository, they have to use git:// or http:// to pull from the central
+and it doesn't trust them, it's normal to use git:// or http:// to pull
-git repository, rather than ssh://. 
+from the central git repository, rather than ssh://.
 
-So, to avoid a MITM attack, propellor checks that any commit it fetches
+Since propellor doesn't trust the central git repository, it checks
-from origin is gpg signed by a trusted gpg key, and refuses to deploy it
+that any commit it fetches from it is gpg signed by a trusted gpg key,
-otherwise.
+and refuses to deploy it otherwise.
 
 That is only done when privdata/keyring.gpg exists. To set it up:
 
@@ -21,8 +21,8 @@ That is only done when privdata/keyring.gpg exists. To set it up:
 
 In order to be secure from the beginning, when `propellor --spin` is used
 to bootstrap propellor on a new host, it transfers the local git repositry
-to the remote host over ssh. After that, the remote host knows the
+to the remote host over ssh. After that, the host knows the gpg key, and
-gpg key, and will use it to verify git fetches.
+will use it to verify git fetches.
 
 Since the propoellor git repository is public, you can't store
 in cleartext private data such as passwords, ssh private keys, etc.

propellor.cabal

@@ -113,8 +113,10 @@ Library
   Other-Modules:
     Propellor.Types.Info
     Propellor.CmdLine
+    Propellor.Git
     Propellor.Gpg
     Propellor.SimpleSh
+    Propellor.Ssh
     Propellor.PrivData.Paths
     Propellor.Protocol
     Propellor.Property.Docker.Shim

src/Propellor/CmdLine.hs

@@ -3,14 +3,9 @@ module Propellor.CmdLine where
 import System.Environment (getArgs)
 import Data.List
 import System.Exit
-import System.Log.Logger
-import System.Log.Formatter
-import System.Log.Handler (setFormatter, LogHandler)
-import System.Log.Handler.Simple
 import System.PosixCompat
 import Control.Exception (bracket)
 import System.Posix.IO
-import Data.Time.Clock.POSIX
 import Control.Concurrent.Async
 import qualified Data.ByteString as B
 import System.Process (std_in, std_out)
@@ -19,54 +14,59 @@ import Propellor
 import Propellor.Protocol
 import Propellor.PrivData.Paths
 import Propellor.Gpg
+import Propellor.Git
+import Propellor.Ssh
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Docker.Shim as DockerShim
 import Utility.FileMode
 import Utility.SafeCommand
-import Utility.UserInfo
 
-usage :: IO a
+usage :: Handle -> IO ()
-usage = do
+usage h = hPutStrLn h $ unlines 
-	putStrLn $ unlines 
+	[ "Usage:"
-		[ "Usage:"
+	, "  propellor"
-		, "  propellor"
+	, "  propellor hostname"
-		, "  propellor hostname"
+	, "  propellor --spin hostname"
-		, "  propellor --spin hostname"
+	, "  propellor --add-key keyid"
-		, "  propellor --add-key keyid"
+	, "  propellor --set field context"
-		, "  propellor --set field context"
+	, "  propellor --dump field context"
-		, "  propellor --dump field context"
+	, "  propellor --edit field context"
-		, "  propellor --edit field context"
+	, "  propellor --list-fields"
-		, "  propellor --list-fields"
+	]
-		]
+
-	exitFailure
+usageError :: [String] -> IO a
+usageError ps = do
+	usage stderr
+	error ("(Unexpected: " ++ show ps)
 
 processCmdLine :: IO CmdLine
 processCmdLine = go =<< getArgs
   where
-	go ("--help":_) = usage
-	go ("--spin":h:[]) = return $ Spin h
-	go ("--boot":h:[]) = return $ Boot h
 	go ("--run":h:[]) = return $ Run h
+	go ("--spin":h:[]) = return $ Spin h
 	go ("--add-key":k:[]) = return $ AddKey k
 	go ("--set":f:c:[]) = withprivfield f c Set
 	go ("--dump":f:c:[]) = withprivfield f c Dump
 	go ("--edit":f:c:[]) = withprivfield f c Edit
 	go ("--list-fields":[]) = return ListFields
+	go ("--help":_) = do	
+		usage stdout
+		exitFailure
+	go ("--update":h:[]) = return $ Update h
+	go ("--boot":h:[]) = return $ Update h -- for back-compat
 	go ("--continue":s:[]) = case readish s of
 		Just cmdline -> return $ Continue cmdline
-		Nothing -> errorMessage "--continue serialization failure"
+		Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")"
-	go ("--chain":h:[]) = return $ Chain h
-	go ("--docker":h:[]) = return $ Docker h
 	go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
 	go (h:[])
-		| "--" `isPrefixOf` h = usage
+		| "--" `isPrefixOf` h = usageError [h]
 		| otherwise = return $ Run h
 	go [] = do
 		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
 		if null s
 			then errorMessage "Cannot determine hostname! Pass it on the command line."
 			else return $ Run s
-	go _ = usage
+	go v = usageError v
 
 	withprivfield s c f = case readish s of
 		Just pf -> return $ f pf (Context c)
@@ -86,7 +86,8 @@ defaultMain hostlist = do
 	go _ (Edit field context) = editPrivData field context
 	go _ ListFields = listPrivDataFields hostlist
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain hn) = withhost hn $ \h -> do
+	go _ (Chain hn isconsole) = withhost hn $ \h -> do
+		when isconsole forceConsole
 		r <- runPropellor h $ ensureProperties $ hostProperties h
 		putStrLn $ "\n" ++ show r
 	go _ (Docker hn) = Docker.chain hn
@@ -94,11 +95,15 @@ defaultMain hostlist = do
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
 	go False (Spin hn) = withhost hn $ spin hn
+	go False cmdline@(SimpleRun hn) = buildFirst cmdline $
+		go False (Run hn)
 	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
 		( onlyProcess $ withhost hn mainProperties
 		, go True (Spin hn)
 		)
-	go False (Boot _) = onlyProcess boot
+	go False (Update _) = do
+		forceConsole
+		onlyProcess update
 
 	withhost :: HostName -> (Host -> IO ()) -> IO ()
 	withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
@@ -137,10 +142,6 @@ buildFirst cmdline next = do
   where
 	getmtime = catchMaybeIO $ getModificationTime "propellor"
 
-getCurrentBranch :: IO String
-getCurrentBranch = takeWhile (/= '\n') 
-	<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
-
 updateFirst :: CmdLine -> IO () -> IO ()
 updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
 
@@ -153,29 +154,14 @@ updateFirst' cmdline next = do
 	
 	oldsha <- getCurrentGitSha1 branchref
 	
-	whenM (doesFileExist keyring) $ do
+	whenM (doesFileExist keyring) $
-		{- To verify origin branch commit's signature, have to
+		ifM (verifyOriginBranch originbranch)
-		 - convince gpg to use our keyring. While running git log.
+			( do
-		 - Which has no way to pass options to gpg.
-		 - Argh! -}
-		let gpgconf = privDataDir </> "gpg.conf"
-		writeFile gpgconf $ unlines
-			[ " keyring " ++ keyring
-			, "no-auto-check-trustdb"
-			]
-		-- gpg is picky about perms
-		modifyFileMode privDataDir (removeModes otherGroupModes)
-		s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
-			(Just [("GNUPGHOME", privDataDir)])
-		nukeFile $ privDataDir </> "trustdb.gpg"
-		nukeFile $ privDataDir </> "pubring.gpg"
-		nukeFile $ privDataDir </> "gpg.conf"
-		if s == "U\n" || s == "G\n"
-			then do
 				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
 				hFlush stdout
 				void $ boolSystem "git" [Param "merge", Param originbranch]
-			else warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
+			, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
+			)
 	
 	newsha <- getCurrentGitSha1 branchref
 
@@ -186,72 +172,26 @@ updateFirst' cmdline next = do
 			, errorMessage "Propellor build failed!" 
 			)
 
-getCurrentGitSha1 :: String -> IO String
-getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
-
 -- spin handles deploying propellor to a remote host, if it's not already
 -- installed there, or updating it if it is. Once the remote propellor is
 -- updated, it's run.
 spin :: HostName -> Host -> IO ()
 spin hn hst = do
-	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
+	void $ actionMessage "Git commit (signed)" $
+		gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
 	-- Push to central origin repo first, if possible.
 	-- The remote propellor will pull from there, which avoids
 	-- us needing to send stuff directly to the remote host.
 	whenM hasOrigin $
-		void $ boolSystem "git" [Param "push"]
+		void $ actionMessage "Push to central git repository" $
+			boolSystem "git" [Param "push"]
 	
 	cacheparams <- toCommand <$> sshCachingParams hn
-	comm cacheparams =<< hostprivdata
+	comm hn hst $ withBothHandles createProcessSuccess
-	unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
+		(proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
+	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
 		error $ "remote propellor failed (running: " ++ runcmd ++")"
   where
-	hostprivdata = show . filterPrivData hst <$> decryptPrivData
-
-	comm cacheparams privdata = 
-		withBothHandles createProcessSuccess
-			(proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
-			(comm' cacheparams privdata)
-	comm' cacheparams privdata (toh, fromh) = loop
-	  where
-		loop = dispatch =<< (maybe Nothing readish <$> getMarked fromh statusMarker)
-		dispatch (Just NeedRepoUrl) = do
-			sendMarked toh repoUrlMarker
-				=<< (fromMaybe "" <$> getRepoUrl)
-			loop
-		dispatch (Just NeedPrivData) = do
-			sendprivdata toh privdata
-			loop
-		dispatch (Just NeedGitPush) = do
-			void $ actionMessage ("Sending git update to " ++ hn) $ do
-				sendMarked toh gitPushMarker ""
-				let p = (proc "git" ["upload-pack", "."])
-					{ std_in = UseHandle fromh
-					, std_out = UseHandle toh
-					}
-				(Nothing, Nothing, Nothing, h) <- createProcess p
-				r <- waitForProcess h
-				-- no more protocol possible after git push
-				hClose fromh
-				hClose toh
-				return (r == ExitSuccess)
-		dispatch (Just NeedGitClone) = do
-			hClose toh
-			hClose fromh
-			sendGitClone hn
-			comm cacheparams privdata
-		-- Ready is only sent by old versions of
-		-- propellor. They expect to get privdata,
-		-- and then no more protocol communication.
-		dispatch (Just Ready) = do
-			sendprivdata toh privdata
-			hClose toh
-			-- Display remaining output.
-			void $ tryIO $ forever $
-				showremote =<< hGetLine fromh
-			hClose fromh
-		dispatch Nothing = return ()
-	
 	user = "root@"++hn
 
 	mkcmd = shellWrap . intercalate " ; "
@@ -272,18 +212,82 @@ spin hn hst = do
 		]
 
 	runcmd = mkcmd
-		[ "cd " ++ localdir ++ " && ./propellor --run " ++ hn ]
+		[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
 
-	showremote s = putStrLn s
+-- Update the privdata, repo url, and git repo over the ssh
+-- connection from the client that ran propellor --spin.
+update :: IO ()
+update = do
+	req NeedRepoUrl repoUrlMarker setRepoUrl
+	makePrivDataDir
+	req NeedPrivData privDataMarker $
+		writeFileProtected privDataLocal
+	req NeedGitPush gitPushMarker $ \_ -> do
+		hin <- dup stdInput
+		hout <- dup stdOutput
+		hClose stdin
+		hClose stdout
+		unlessM (boolSystem "git" (pullparams hin hout)) $
+			errorMessage "git pull from client failed"
+  where
+	pullparams hin hout =
+		[ Param "pull"
+		, Param "--progress"
+		, Param "--upload-pack"
+		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+		, Param "."
+		]
 
-	sendprivdata toh privdata = void $
+comm :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
-		actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
+comm hn hst connect = connect go
-			sendMarked toh privDataMarker privdata
+  where
-			return True
+	go (toh, fromh) = do
+		let loop = go (toh, fromh)
+		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
+		case v of
+			(Just NeedRepoUrl) -> do
+				sendRepoUrl toh
+				loop
+			(Just NeedPrivData) -> do
+				sendPrivData hn hst toh
+				loop
+			(Just NeedGitPush) -> do
+				sendGitUpdate hn fromh toh
+				-- no more protocol possible after git push
+				hClose fromh
+				hClose toh
+			(Just NeedGitClone) -> do
+				hClose toh
+				hClose fromh
+				sendGitClone hn
+				comm hn hst connect
+			Nothing -> return ()
+
+sendRepoUrl :: Handle -> IO ()
+sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
+
+sendPrivData :: HostName -> Host -> Handle -> IO ()
+sendPrivData hn hst toh = do
+	privdata <- show . filterPrivData hst <$> decryptPrivData
+	void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
+		sendMarked toh privDataMarker privdata
+		return True
+
+sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
+sendGitUpdate hn fromh toh =
+	void $ actionMessage ("Sending git update to " ++ hn) $ do
+		sendMarked toh gitPushMarker ""
+		(Nothing, Nothing, Nothing, h) <- createProcess p
+		(==) ExitSuccess <$> waitForProcess h
+  where
+	p = (proc "git" ["upload-pack", "."])
+		{ std_in = UseHandle fromh
+		, std_out = UseHandle toh
+		}
 
 -- Initial git clone, used for bootstrapping.
 sendGitClone :: HostName -> IO ()
-sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
+sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
 	branch <- getCurrentBranch
 	cacheparams <- sshCachingParams hn
 	withTmpFile "propellor.git" $ \tmp _ -> allM id
@@ -301,23 +305,6 @@ sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
 		, "rm -f " ++ remotebundle
 		]
 
--- Called "boot" for historical reasons, but what this really does is
--- update the privdata, repo url, and git repo over the ssh connection from the
--- client that ran propellor --spin.
-boot :: IO ()
-boot = do
-	req NeedRepoUrl repoUrlMarker setRepoUrl
-	makePrivDataDir
-	req NeedPrivData privDataMarker $
-		writeFileProtected privDataLocal
-	req NeedGitPush gitPushMarker $ \_ -> do
-		hin <- dup stdInput
-		hout <- dup stdOutput
-		hClose stdin
-		hClose stdout
-		unlessM (boolSystem "git" [Param "pull", Param "--progress", Param "--upload-pack", Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout, Param "."]) $
-			errorMessage "git pull from client failed"
-
 -- Shim for git push over the propellor ssh channel.
 -- Reads from stdin and sends it to hout;
 -- reads from hin and sends it to stdout.
@@ -342,78 +329,3 @@ gitPush hin hout = void $ fromstdin `concurrently` tostdout
 				B.hPut toh b
 				hFlush toh
 				connect fromh toh
-
-hasOrigin :: IO Bool
-hasOrigin = do
-	rs <- lines <$> readProcess "git" ["remote"]
-	return $ "origin" `elem` rs
-
-setRepoUrl :: String -> IO ()
-setRepoUrl "" = return ()
-setRepoUrl url = do
-	subcmd <- ifM hasOrigin (pure "set-url", pure "add")
-	void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url]
-	-- same as --set-upstream-to, except origin branch
-	-- may not have been pulled yet
-	branch <- getCurrentBranch
-	let branchval s = "branch." ++ branch ++ "." ++ s
-	void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"]
-	void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch]
-
-getRepoUrl :: IO (Maybe String)
-getRepoUrl = getM get urls
-  where
-	urls = ["remote.deploy.url", "remote.origin.url"]
-	get u = do
-		v <- catchMaybeIO $ 
-			takeWhile (/= '\n') 
-				<$> readProcess "git" ["config", u]
-		return $ case v of
-			Just url | not (null url) -> Just url
-			_ -> Nothing
-
-checkDebugMode :: IO ()
-checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
-  where
-	go (Just "1") = do
-		f <- setFormatter
-			<$> streamHandler stderr DEBUG
-			<*> pure (simpleLogFormatter "[$time] $msg")
-		updateGlobalLogger rootLoggerName $ 
-			setLevel DEBUG .  setHandlers [f]
-	go _ = noop
-
--- Parameters can be passed to both ssh and scp, to enable a ssh connection
--- caching socket.
---
--- If the socket already exists, check if its mtime is older than 10
--- minutes, and if so stop that ssh process, in order to not try to
--- use an old stale connection. (atime would be nicer, but there's
--- a good chance a laptop uses noatime)
-sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hn = do
-	home <- myHomeDir
-	let cachedir = home </> ".ssh" </> "propellor"
-	createDirectoryIfMissing False cachedir
-	let socketfile = cachedir </> hn ++ ".sock"
-	let ps = 
-		[ Param "-o", Param ("ControlPath=" ++ socketfile)
-		, Params "-o ControlMaster=auto -o ControlPersist=yes"
-		]
-
-	maybe noop (expireold ps socketfile)
-		=<< catchMaybeIO (getFileStatus socketfile)
-	
-	return ps
-		
-  where
-	expireold ps f s = do
-		now <- truncate <$> getPOSIXTime :: IO Integer
-		if modificationTime s > fromIntegral now - tenminutes
-			then touchFile f
-			else do
-				void $ boolSystem "ssh" $
-					[ Params "-O stop" ] ++ ps ++
-					[ Param "localhost" ]
-				nukeFile f
-	tenminutes = 600

src/Propellor/Git.hs

@@ -0,0 +1,64 @@
+module Propellor.Git where
+
+import Propellor
+import Propellor.PrivData.Paths
+import Propellor.Gpg
+import Utility.SafeCommand
+import Utility.FileMode
+
+getCurrentBranch :: IO String
+getCurrentBranch = takeWhile (/= '\n') 
+	<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
+
+getCurrentGitSha1 :: String -> IO String
+getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
+
+setRepoUrl :: String -> IO ()
+setRepoUrl "" = return ()
+setRepoUrl url = do
+	subcmd <- ifM hasOrigin (pure "set-url", pure "add")
+	void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url]
+	-- same as --set-upstream-to, except origin branch
+	-- may not have been pulled yet
+	branch <- getCurrentBranch
+	let branchval s = "branch." ++ branch ++ "." ++ s
+	void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"]
+	void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch]
+
+getRepoUrl :: IO (Maybe String)
+getRepoUrl = getM get urls
+  where
+	urls = ["remote.deploy.url", "remote.origin.url"]
+	get u = do
+		v <- catchMaybeIO $ 
+			takeWhile (/= '\n') 
+				<$> readProcess "git" ["config", u]
+		return $ case v of
+			Just url | not (null url) -> Just url
+			_ -> Nothing
+
+hasOrigin :: IO Bool
+hasOrigin = do
+	rs <- lines <$> readProcess "git" ["remote"]
+	return $ "origin" `elem` rs
+
+{- To verify origin branch commit's signature, have to convince gpg
+ - to use our keyring.
+ - While running git log. Which has no way to pass options to gpg.
+ - Argh!
+ -}
+verifyOriginBranch :: String -> IO Bool
+verifyOriginBranch originbranch = do
+	let gpgconf = privDataDir </> "gpg.conf"
+	writeFile gpgconf $ unlines
+		[ " keyring " ++ keyring
+		, "no-auto-check-trustdb"
+		]
+	-- gpg is picky about perms
+	modifyFileMode privDataDir (removeModes otherGroupModes)
+	s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
+		(Just [("GNUPGHOME", privDataDir)])
+	nukeFile $ privDataDir </> "trustdb.gpg"
+	nukeFile $ privDataDir </> "pubring.gpg"
+	nukeFile $ privDataDir </> "gpg.conf"
+	return (s == "U\n" || s == "G\n")

src/Propellor/Message.hs

@@ -5,21 +5,34 @@ module Propellor.Message where
 import System.Console.ANSI
 import System.IO
 import System.Log.Logger
+import System.Log.Formatter
+import System.Log.Handler (setFormatter, LogHandler)
+import System.Log.Handler.Simple
 import "mtl" Control.Monad.Reader
+import Data.Maybe
+import Control.Applicative
 
 import Propellor.Types
 import Utility.Monad
+import Utility.Env
 
 data MessageHandle
 	= ConsoleMessageHandle
 	| TextMessageHandle
 
 mkMessageHandle :: IO MessageHandle
-mkMessageHandle = ifM (hIsTerminalDevice stdout)
+mkMessageHandle = ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
 	( return ConsoleMessageHandle
 	, return TextMessageHandle
 	)
 
+forceConsole :: IO ()
+forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True
+
+isConsole :: MessageHandle -> Bool
+isConsole ConsoleMessageHandle = True
+isConsole _ = False
+
 whenConsole :: MessageHandle -> IO () -> IO ()
 whenConsole ConsoleMessageHandle a = a
 whenConsole _ _ = return ()
@@ -88,3 +101,14 @@ colorLine h intensity color msg = do
 -- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
 debug :: [String] -> IO ()
 debug = debugM "propellor" . unwords
+
+checkDebugMode :: IO ()
+checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
+  where
+	go (Just "1") = do
+		f <- setFormatter
+			<$> streamHandler stderr DEBUG
+			<*> pure (simpleLogFormatter "[$time] $msg")
+		updateGlobalLogger rootLoggerName $ 
+			setLevel DEBUG .  setHandlers [f]
+	go _ = noop

src/Propellor/Property/Docker.hs

@@ -385,7 +385,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, "--docker", fromContainerId cid]
+			[shim, "--continue", show (Docker (fromContainerId cid))]
 
 -- | Called when propellor is running inside a docker container.
 -- The string should be the container's ContainerId.
@@ -416,7 +416,7 @@ chain s = case toContainerId s of
 		-- 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]) $
+			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid) False]) $
 				warningMessage "Boot provision failed!"
 		void $ async $ job reapzombies
 		void $ async $ job $ simpleSh $ namedPipe cid
@@ -440,13 +440,13 @@ chain 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)
+	msgh <- mkMessageHandle
+	let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)]
 	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
 	when (r /= FailedChange) $
 		setProvisionedFlag cid 
 	return r
   where
-	params = ["--continue", show $ Chain $ containerHostName cid]
-
 	go lastline (v:rest) = case v of
 		StdoutLine s -> do
 			maybe noop putStrLn lastline

src/Propellor/Protocol.hs

@@ -1,7 +1,7 @@
 -- | This is a simple line-based protocol used for communication between
 -- a local and remote propellor. It's sent over a ssh channel, and lines of
 -- the protocol can be interspersed with other, non-protocol lines
--- that should be ignored.
+-- that should be passed through to be displayed.
 
 module Propellor.Protocol where
 
@@ -9,7 +9,7 @@ import Data.List
 
 import Propellor
 
-data Stage = Ready | NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush
+data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush
 	deriving (Read, Show, Eq)
 
 type Marker = String
@@ -48,7 +48,10 @@ getMarked h marker = go =<< catchMaybeIO (hGetLine h)
   where
 	go Nothing = return Nothing
 	go (Just l) = case fromMarked marker l of
-		Nothing -> getMarked h marker
+		Nothing -> do
+			unless (null l) $
+				hPutStrLn stderr l
+			getMarked h marker
 		Just v -> return (Just v)
 
 req :: Stage -> Marker -> (String -> IO ()) -> IO ()

src/Propellor/Ssh.hs

@@ -0,0 +1,43 @@
+module Propellor.Ssh where
+
+import Propellor
+import Utility.SafeCommand
+import Utility.UserInfo
+
+import System.PosixCompat
+import Data.Time.Clock.POSIX
+
+-- Parameters can be passed to both ssh and scp, to enable a ssh connection
+-- caching socket.
+--
+-- If the socket already exists, check if its mtime is older than 10
+-- minutes, and if so stop that ssh process, in order to not try to
+-- use an old stale connection. (atime would be nicer, but there's
+-- a good chance a laptop uses noatime)
+sshCachingParams :: HostName -> IO [CommandParam]
+sshCachingParams hn = do
+	home <- myHomeDir
+	let cachedir = home </> ".ssh" </> "propellor"
+	createDirectoryIfMissing False cachedir
+	let socketfile = cachedir </> hn ++ ".sock"
+	let ps = 
+		[ Param "-o", Param ("ControlPath=" ++ socketfile)
+		, Params "-o ControlMaster=auto -o ControlPersist=yes"
+		]
+
+	maybe noop (expireold ps socketfile)
+		=<< catchMaybeIO (getFileStatus socketfile)
+	
+	return ps
+		
+  where
+	expireold ps f s = do
+		now <- truncate <$> getPOSIXTime :: IO Integer
+		if modificationTime s > fromIntegral now - tenminutes
+			then touchFile f
+			else do
+				void $ boolSystem "ssh" $
+					[ Params "-O stop" ] ++ ps ++
+					[ Param "localhost" ]
+				nukeFile f
+	tenminutes = 600

src/Propellor/Types.hs

@@ -138,14 +138,15 @@ instance ActionResult Result where
 data CmdLine
 	= Run HostName
 	| Spin HostName
+	| SimpleRun HostName
 	| Set PrivDataField Context
 	| Dump PrivDataField Context
 	| Edit PrivDataField Context
 	| ListFields
 	| AddKey String
 	| Continue CmdLine
-	| Chain HostName
+	| Chain HostName Bool
-	| Boot HostName
+	| Update HostName
 	| Docker HostName
 	| GitPush Fd Fd
 	deriving (Read, Show, Eq)