Merge branch 'joeyconfig'

5 files changed, 68 insertions, 54 deletions

diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 49ca689f..ed6c2d85 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -84,13 +84,13 @@ askInfo = asks (fromInfo . hostInfo)
 -- It also lets the type checker know that all the properties of the
 -- host must support Debian.
 --
--- >	& osDebian (Stable "jessie") X86_64
+-- >	& osDebian (Stable "stretch") X86_64
 osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
 osDebian = osDebian' Linux
 
 -- Use to specify a different `DebianKernel` than the default `Linux`
 --
--- >	& osDebian' KFreeBSD (Stable "jessie") X86_64
+-- >	& osDebian' KFreeBSD (Stable "stretch") X86_64
 osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
 osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
 
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 97573516..c56f0c5a 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -102,7 +102,7 @@ actionMessage' mhn desc a = do
 
 warningMessage :: MonadIO m => String -> m ()
 warningMessage s = liftIO $
-	outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
+	errorConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
 
 infoMessage :: MonadIO m => [String] -> m ()
 infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
@@ -113,7 +113,7 @@ infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
 -- property fail. Propellor will continue to the next property.
 errorMessage :: MonadIO m => String -> m a
 errorMessage s = liftIO $ do
-	outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
+	errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
 	-- Normally this exception gets caught and is not displayed,
 	-- and propellor continues. So it's only displayed if not
 	-- caught, and so we say, cannot continue.
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index e90155f3..ae7e0404 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -53,7 +53,11 @@ sendMarked' h marker s = do
 	hFlush h
 
 getMarked :: Handle -> Marker -> IO (Maybe String)
-getMarked h marker = go =<< catchMaybeIO (hGetLine h)
+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)
   where
 	go Nothing = return Nothing
 	go (Just l) = case fromMarked marker l of
@@ -65,8 +69,8 @@ getMarked h marker = go =<< catchMaybeIO (hGetLine h)
 			debug ["received marked", marker]
 			return (Just v)
 
-req :: Stage -> Marker -> (String -> IO ()) -> IO ()
-req stage marker a = do
+reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()
+reqMarked 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 3b3729f9..cd964e16 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -178,34 +178,16 @@ getSshTarget target hst
 update :: Maybe HostName -> IO ()
 update forhost = do
 	whenM hasGitRepo $
-		req NeedRepoUrl repoUrlMarker setRepoUrl
+		reqMarked NeedRepoUrl repoUrlMarker setRepoUrl
 
 	makePrivDataDir
 	createDirectoryIfMissing True (takeDirectory privfile)
-	req NeedPrivData privDataMarker $
+	reqMarked NeedPrivData privDataMarker $
 		writeFileProtected privfile
 
 	whenM hasGitRepo $
-		req NeedGitPush gitPushMarker $ \_ -> do
-			hin <- dup stdInput
-			hout <- dup stdOutput
-			hClose stdin
-			hClose stdout
-			-- Not using git pull because git 2.5.0 badly
-			-- broke its option parser.
-			unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
-				errorMessage "git fetch from client failed"
-			unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
-				errorMessage "git merge from client failed"
+		gitPullFromUpdateServer
   where
-	pullparams hin hout =
-		[ Param "fetch"
-		, Param "--progress"
-		, Param "--upload-pack"
-		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
-		, Param "."
-		]
-
 	-- When --spin --relay is run, get a privdata file
 	-- to be relayed to the target host.
 	privfile = maybe privDataLocal privDataRelay forhost
@@ -336,31 +318,6 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
 		, "rm -f " ++ remotetarball
 		]
 
--- 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.
-gitPushHelper :: Fd -> Fd -> IO ()
-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
-  where
-	fromstdin = do
-		h <- fdToHandle hout
-		connect stdin h
-	tostdout = do
-		h <- fdToHandle hin
-		connect h stdout
-	connect fromh toh = do
-		hSetBinaryMode fromh True
-		hSetBinaryMode toh True
-		b <- B.hGetSome fromh 40960
-		if B.null b
-			then do
-				hClose fromh
-				hClose toh
-			else do
-				B.hPut toh b
-				hFlush toh
-				connect fromh toh
-
 mergeSpin :: IO ()
 mergeSpin = do
 	branch <- getCurrentBranch
@@ -388,3 +345,56 @@ findLastNonSpinCommit = do
 
 spinCommitMessage :: String
 spinCommitMessage = "propellor spin"
+
+-- Stdin and stdout are connected to the updateServer over ssh.
+-- 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
+	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"
+	unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
+		errorMessage "git merge from client failed"
+  where
+	fetchparams hin hout =
+		[ Param "fetch"
+		, Param "--progress"
+		, Param "--upload-pack"
+		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+		, Param "."
+		]
+
+-- 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.
+gitPushHelper :: Fd -> Fd -> IO ()
+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
+  where
+	fromstdin = do
+		h <- fdToHandle hout
+		stdin *>* h
+	tostdout = do
+		h <- fdToHandle hin
+		h *>* stdout
+
+-- Forward data from one handle to another.
+(*>*) :: Handle -> Handle -> IO ()
+fromh *>* toh = do
+	b <- B.hGetSome fromh 40960
+	if B.null b
+		then do
+			hClose fromh
+			hClose toh
+		else do
+			B.hPut toh b
+			hFlush toh
+			fromh *>* toh
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 41f839f1..01d777a4 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -59,7 +59,7 @@ data DebianKernel = Linux | KFreeBSD | Hurd
 	deriving (Show, Eq)
 
 -- | Debian has several rolling suites, and a number of stable releases,
--- such as Stable "jessie".
+-- such as Stable "stretch".
 data DebianSuite = Experimental | Unstable | Testing | Stable Release
 	deriving (Show, Eq)