broke out Server module

propellor.cabal

@@ -115,6 +115,7 @@ Library
     Propellor.CmdLine
     Propellor.Git
     Propellor.Gpg
+    Propellor.Server
     Propellor.SimpleSh
     Propellor.Ssh
     Propellor.PrivData.Paths

src/Propellor/CmdLine.hs

@@ -6,19 +6,15 @@ import System.Exit
 import System.PosixCompat
 import Control.Exception (bracket)
 import System.Posix.IO
-import Control.Concurrent.Async
-import qualified Data.ByteString as B
-import System.Process (std_in, std_out)
 
 import Propellor
 import Propellor.Protocol
-import Propellor.PrivData.Paths
 import Propellor.Gpg
 import Propellor.Git
 import Propellor.Ssh
+import Propellor.Server
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Docker.Shim as DockerShim
-import Utility.FileMode
 import Utility.SafeCommand
 
 usage :: Handle -> IO ()
@@ -91,7 +87,7 @@ defaultMain hostlist = do
 		r <- runPropellor h $ ensureProperties $ hostProperties h
 		putStrLn $ "\n" ++ show r
 	go _ (Docker hn) = Docker.chain hn
-	go _ (GitPush fin fout) = gitPush fin fout
+	go _ (GitPush fin fout) = gitPushHelper fin fout
 	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
@@ -172,9 +168,6 @@ updateFirst' cmdline next = do
 			, errorMessage "Propellor build failed!" 
 			)
 
--- 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 $ actionMessage "Git commit (signed)" $
@@ -187,8 +180,12 @@ spin hn hst = do
 			boolSystem "git" [Param "push"]
 	
 	cacheparams <- toCommand <$> sshCachingParams hn
-	comm hn hst $ withBothHandles createProcessSuccess
+
-		(proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
+	-- Install, or update the remote propellor.
+	updateServer hn hst $ withBothHandles createProcessSuccess
+		(proc "ssh" $ cacheparams ++ [user, updatecmd])
+
+	-- And now we can run it.
 	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
 		error $ "remote propellor failed (running: " ++ runcmd ++")"
   where
@@ -196,7 +193,7 @@ spin hn hst = do
 
 	mkcmd = shellWrap . intercalate " ; "
 
-	bootstrapcmd = mkcmd
+	updatecmd = mkcmd
 		[ "if [ ! -d " ++ localdir ++ " ]"
 		, "then " ++ intercalate " && "
 			[ "apt-get update"
@@ -213,119 +210,3 @@ spin hn hst = do
 
 	runcmd = mkcmd
 		[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
-
--- 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 "."
-		]
-
-comm :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
-comm hn hst connect = connect go
-  where
-	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 ("Clone git repository to " ++ hn) $ do
-	branch <- getCurrentBranch
-	cacheparams <- sshCachingParams hn
-	withTmpFile "propellor.git" $ \tmp _ -> allM id
-		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
-		]
-  where
-	remotebundle = "/usr/local/propellor.git"
-	unpackcmd branch = shellWrap $ intercalate " && "
-		[ "git clone " ++ remotebundle ++ " " ++ localdir
-		, "cd " ++ localdir
-		, "git checkout -b " ++ branch
-		, "git remote rm origin"
-		, "rm -f " ++ remotebundle
-		]
-
--- 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.
-gitPush :: Fd -> Fd -> IO ()
-gitPush 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

src/Propellor/Protocol.hs

@@ -2,6 +2,10 @@
 -- 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 passed through to be displayed.
+--
+-- Avoid making backwards-incompatible changes to this protocol,
+-- since propellor needs to use this protocol to update itself to new
+-- versions speaking newer versions of the protocol.
 
 module Propellor.Protocol where
 

src/Propellor/Server.hs

@@ -0,0 +1,140 @@
+module Propellor.Server (
+	update,
+	updateServer,
+	gitPushHelper
+) where
+
+import Data.List
+import System.Exit
+import System.PosixCompat
+import System.Posix.IO
+import Control.Concurrent.Async
+import qualified Data.ByteString as B
+import System.Process (std_in, std_out)
+
+import Propellor
+import Propellor.Protocol
+import Propellor.PrivData.Paths
+import Propellor.Git
+import Propellor.Ssh
+import Utility.FileMode
+import Utility.SafeCommand
+
+-- Update the privdata, repo url, and git repo over the ssh
+-- connection, talking the the user's local propellor instance which is
+-- running the updateServer
+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 "."
+		]
+
+-- The connect action should ssh to the remote host and run the provided
+-- calback action.
+updateServer :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
+updateServer hn hst connect = connect go
+  where
+	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
+				updateServer 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 ("Clone git repository to " ++ hn) $ do
+	branch <- getCurrentBranch
+	cacheparams <- sshCachingParams hn
+	withTmpFile "propellor.git" $ \tmp _ -> allM id
+		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
+		]
+  where
+	remotebundle = "/usr/local/propellor.git"
+	unpackcmd branch = shellWrap $ intercalate " && "
+		[ "git clone " ++ remotebundle ++ " " ++ localdir
+		, "cd " ++ localdir
+		, "git checkout -b " ++ branch
+		, "git remote rm origin"
+		, "rm -f " ++ remotebundle
+		]
+
+-- 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