Merge branch 'joeyconfig'

1 files changed, 27 insertions, 58 deletions

diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index ec2ca7ed..f5cfc783 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -7,13 +7,12 @@ import System.Environment (getArgs)
 import Data.List
 import System.Exit
 import System.PosixCompat
+import qualified Network.BSD
 
 import Propellor
-import Propellor.Protocol
 import Propellor.Gpg
 import Propellor.Git
-import Propellor.Ssh
-import Propellor.Server
+import Propellor.Spin
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Shim as Shim
@@ -24,7 +23,7 @@ usage h = hPutStrLn h $ unlines
 	[ "Usage:"
 	, "  propellor"
 	, "  propellor hostname"
-	, "  propellor --spin hostname"
+	, "  propellor --spin targethost [--via relayhost]"
 	, "  propellor --add-key keyid"
 	, "  propellor --set field context"
 	, "  propellor --dump field context"
@@ -40,8 +39,8 @@ usageError ps = do
 processCmdLine :: IO CmdLine
 processCmdLine = go =<< getArgs
   where
-	go ("--run":h:[]) = return $ Run h
-	go ("--spin":h:[]) = return $ Spin h
+	go ("--spin":h:[]) = Spin <$> hostname h <*> pure Nothing
+	go ("--spin":h:"--via":r:[]) = Spin <$> hostname h <*> pure (Just r)
 	go ("--add-key":k:[]) = return $ AddKey k
 	go ("--set":f:c:[]) = withprivfield f c Set
 	go ("--dump":f:c:[]) = withprivfield f c Dump
@@ -50,15 +49,15 @@ processCmdLine = go =<< getArgs
 	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 (" ++ s ++ ")"
+	go ("--update":_:[]) = return $ Update Nothing
+	go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
+	go ("--serialized":s:[]) = serialized Serialized s
+	go ("--continue":s:[]) = serialized Continue s
 	go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
+	go ("--run":h:[]) = go [h]
 	go (h:[])
 		| "--" `isPrefixOf` h = usageError [h]
-		| otherwise = return $ Run h
+		| otherwise = Run <$> hostname h
 	go [] = do
 		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
 		if null s
@@ -70,6 +69,10 @@ processCmdLine = go =<< getArgs
 		Just pf -> return $ f pf (Context c)
 		Nothing -> errorMessage $ "Unknown privdata field " ++ s
 
+	serialized mk s = case readish s of
+		Just cmdline -> return $ mk cmdline
+		Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"
+
 -- | Runs propellor on hosts, as controlled by command-line options.
 defaultMain :: [Host] -> IO ()
 defaultMain hostlist = do
@@ -79,6 +82,7 @@ defaultMain hostlist = do
 	debug ["command line: ", show cmdline]
 	go True cmdline
   where
+	go _ (Serialized cmdline) = go True cmdline
 	go _ (Continue cmdline) = go False cmdline
 	go _ (Set field context) = setPrivData field context
 	go _ (Dump field context) = dumpPrivData field context
@@ -89,15 +93,16 @@ defaultMain hostlist = do
 	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
 	go _ (DockerInit hn) = Docker.init hn
 	go _ (GitPush fin fout) = gitPushHelper fin fout
-	go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
-	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
+	go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
+	go _ (Update (Just h)) = forceConsole >> fetchFirst (update (Just h))
+	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 (Spin hn r) = withhost hn $ spin hn r
 	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 True (Spin hn Nothing)
 		)
 
 	withhost :: HostName -> (Host -> IO ()) -> IO ()
@@ -148,45 +153,9 @@ updateFirst' cmdline next = ifM fetchOrigin
 	, next
 	)
 
-spin :: HostName -> Host -> IO ()
-spin hn hst = do
-	void $ actionMessage "Git commit" $
-		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 $ actionMessage "Push to central git repository" $
-			boolSystem "git" [Param "push"]
-	
-	cacheparams <- toCommand <$> sshCachingParams hn
-
-	-- 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"
-  where
-	user = "root@"++hn
-
-	mkcmd = shellWrap . intercalate " ; "
-
-	updatecmd = mkcmd
-		[ "if [ ! -d " ++ localdir ++ " ]"
-		, "then (" ++ intercalate " && "
-			[ "apt-get update"
-			, "apt-get --no-install-recommends --no-upgrade -y install git make"
-			, "echo " ++ toMarked statusMarker (show NeedGitClone)
-			] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
-		, "else " ++ intercalate " && "
-			[ "cd " ++ localdir
-			, "if ! test -x ./propellor; then make deps build; fi"
-			, "./propellor --boot " ++ hn
-			]
-		, "fi"
-		]
-
-	runcmd = mkcmd
-		[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
+hostname :: String -> IO HostName
+hostname s
+	| "." `isInfixOf` s = pure s
+	| otherwise = do
+		h <- Network.BSD.getHostByName s
+		return (Network.BSD.hostName h)