Merge branch 'joeyconfig'

.gitignore

@@ -7,3 +7,4 @@ Setup
 Setup.hi
 Setup.o
 docker
+propellor.1

config-joey.hs

@@ -26,6 +26,7 @@ import qualified Propellor.Property.Obnam as Obnam
 import qualified Propellor.Property.Gpg as Gpg
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.Systemd as Systemd
+import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
 import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
 import qualified Propellor.Property.HostingProvider.Linode as Linode
@@ -46,6 +47,7 @@ hosts =                --                  (o)  `
 	, kite
 	, diatom
 	, elephant
+	, alien
 	] ++ monsters
 
 darkstar :: Host
@@ -81,18 +83,21 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
 	! Ssh.listenPort 80
 	! Ssh.listenPort 443
 
-	! Chroot.provisioned testChroot
 	& Systemd.persistentJournal
-	& Systemd.nspawned meow
+	! Systemd.nspawned meow
 	
 meow :: Systemd.Container
 meow = Systemd.container "meow" (Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty)
 	& Apt.serviceInstalledRunning "uptimed"
 	& alias "meow.kitenet.net"
-	
+
-testChroot :: Chroot.Chroot
+alien :: Host
-testChroot = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty "/tmp/chroot"
+alien = host "alientest.kitenet.net"
-	& File.hasContent "/foo" ["hello"]
+	& ipv4 "104.131.106.199"
+	& Chroot.provisioned
+		( Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.MinBase "/debian"
+			& Apt.serviceInstalledRunning "uptimed"
+		)
 
 orca :: Host
 orca = standardSystem "orca.kitenet.net" Unstable "amd64"

debian/changelog

@@ -3,8 +3,13 @@ propellor (1.0.1) UNRELEASED; urgency=medium
   * propellor --spin can now deploy propellor to hosts that do not have 
     git, ghc, or apt-get. This is accomplished by uploading a fairly
     portable precompiled tarball of propellor.
-  * --spin host --via host causes propellor to bounce through an intermediate
+  * --spin target --via relay causes propellor to bounce through an
-    host, which handles any necessary provisioning of the host being spun.
+    intermediate relay host, which handles any necessary uploads
+    when provisioning the target host.
+  * Hostname parameters not containing dots are looked up in the DNS to
+    find the full hostname.
+  * Added group-related properties. Thanks, Félix Sipma.
+  * Added Git.barerepo. Thanks, Félix Sipma.
 
  -- Joey Hess <joeyh@debian.org>  Sat, 22 Nov 2014 00:12:35 -0400
 

doc/usage.mdwn

@@ -20,11 +20,18 @@ action as needed to satisfy the configured properties of the local host.
 
 # OPTIONS
 
-* --spin hostname
+* --spin targethost [--via relayhost]
 
-  Causes propellor to automatically install itself on the specified host,
+  Causes propellor to automatically install itself on the specified target
-  or if it's already installed there, push any updates. Propellor is then
+  host, or if it's already installed there, push any updates. Propellor is
-  run on the host, to satisfy its configured properties.
+  then run on the target host, to satisfy its configured properties.
+
+  When run with --via, propellor sshes to the relay host and runs
+  `propellor --spin hostname` from there. This can be useful when
+  propellor is installing itself, since most of the data transfer
+  is done between relay host and target host. Note that propellor
+  uses ssh agent forwarding to make this work, and the relay host
+  sees any privdata belonging to the target host.
 
 * --add-key keyid
 
@@ -52,6 +59,13 @@ action as needed to satisfy the configured properties of the local host.
 
   Opens $EDITOR on the privdata value.
 
+* hostname
+
+  When run with a hostname and no other options, propellor will
+  provision the local host with the configuration of that hostname.
+  This is useful when the local host doesn't yet have its hostname set
+  correctly.
+
 # ENVIRONMENT
 
 Set `PROPELLOR_DEBUG=1` to make propellor output each command it runs and

propellor.cabal

@@ -83,6 +83,7 @@ Library
     Propellor.Property.Firewall
     Propellor.Property.Git
     Propellor.Property.Gpg
+    Propellor.Property.Group
     Propellor.Property.Grub
     Propellor.Property.Network
     Propellor.Property.Nginx
@@ -121,11 +122,12 @@ Library
   Other-Modules:
     Propellor.Git
     Propellor.Gpg
-    Propellor.Server
+    Propellor.Spin
     Propellor.Ssh
     Propellor.PrivData.Paths
     Propellor.Protocol
     Propellor.Shim
+    Propellor.Property.Chroot.Util
     Utility.Applicative
     Utility.Data
     Utility.Directory

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.Spin
-import Propellor.Server
 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:[]) = Spin <$> hostname h <*> pure Nothing
-	go ("--spin":h:[]) = return $ Spin h
+	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 ("--update":_:[]) = return $ Update Nothing
-	go ("--boot":h:[]) = return $ Update h -- for back-compat
+	go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
-	go ("--continue":s:[]) = case readish s of
+	go ("--serialized":s:[]) = serialized Serialized s
-		Just cmdline -> return $ Continue cmdline
+	go ("--continue":s:[]) = serialized Continue s
-		Nothing -> errorMessage $ "--continue serialization failure (" ++ 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 _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
-	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
+	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 ()
+hostname :: String -> IO HostName
-spin hn hst = do
+hostname s
-	void $ actionMessage "Git commit" $
+	| "." `isInfixOf` s = pure s
-		gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
+	| otherwise = do
-	-- Push to central origin repo first, if possible.
+		h <- Network.BSD.getHostByName s
-	-- The remote propellor will pull from there, which avoids
+		return (Network.BSD.hostName h)
-	-- 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)) ]

src/Propellor/Engine.hs

@@ -11,6 +11,8 @@ import "mtl" Control.Monad.Reader
 import Control.Exception (bracket)
 import System.PosixCompat
 import System.Posix.IO
+import System.FilePath
+import System.Directory
 
 import Propellor.Types
 import Propellor.Message
@@ -60,6 +62,7 @@ onlyProcess :: FilePath -> IO a -> IO a
 onlyProcess lockfile a = bracket lock unlock (const a)
   where
 	lock = do
+		createDirectoryIfMissing True (takeDirectory lockfile)
 		l <- createFile lockfile stdFileMode
 		setLock l (WriteLock, AbsoluteSeek, 0, 0)
 			`catchIO` const alreadyrunning

src/Propellor/Git.hs

@@ -42,6 +42,9 @@ hasOrigin = catchDefaultIO False $ do
 	rs <- lines <$> readProcess "git" ["remote"]
 	return $ "origin" `elem` rs
 
+hasGitRepo :: IO Bool
+hasGitRepo = doesFileExist ".git/HEAD"
+
 {- 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.

src/Propellor/PrivData/Paths.hs

@@ -10,3 +10,6 @@ privDataFile = privDataDir </> "privdata.gpg"
 
 privDataLocal :: FilePath
 privDataLocal = privDataDir </> "local"
+
+privDataRelay :: String -> FilePath
+privDataRelay host = privDataDir </> "relay" </> host

src/Propellor/Property/Chroot.hs

@@ -11,6 +11,7 @@ module Propellor.Property.Chroot (
 
 import Propellor
 import Propellor.Types.Chroot
+import Propellor.Property.Chroot.Util
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Systemd.Core as Systemd
 import qualified Propellor.Shim as Shim
@@ -88,7 +89,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
 	let me = localdir </> "propellor"
 	shim <- liftIO $ ifM (doesDirectoryExist d)
 		( pure (Shim.file me d)
-		, Shim.setup me d
+		, Shim.setup me Nothing d
 		)
 	ifM (liftIO $ bindmount shim)
 		( chainprovision shim
@@ -109,12 +110,14 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
 	chainprovision shim = do
 		parenthost <- asks hostName
 		cmd <- liftIO $ toChain parenthost c systemdonly
+		pe <- liftIO standardPathEnv
 		let p = mkproc
 			[ shim
 			, "--continue"
 			, show cmd
 			]
-		liftIO $ withHandle StdoutHandle createProcessSuccess p
+		let p' = p { env = Just pe }
+		liftIO $ withHandle StdoutHandle createProcessSuccess p'
 			processChainOutput
 
 toChain :: HostName -> Chroot -> Bool -> IO CmdLine

src/Propellor/Property/Chroot/Util.hs

@@ -0,0 +1,15 @@
+module Propellor.Property.Chroot.Util where
+
+import Utility.Env
+import Control.Applicative
+
+-- When chrooting, it's useful to ensure that PATH has all the standard
+-- directories in it. This adds those directories to whatever PATH is
+-- already set.
+standardPathEnv :: IO [(String, String)]
+standardPathEnv = do
+	path <- getEnvDefault "PATH" "/bin"
+	addEntry "PATH" (path ++ std)
+		<$> getEnvironment
+  where
+	std = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"

src/Propellor/Property/Debootstrap.hs

@@ -8,6 +8,7 @@ module Propellor.Property.Debootstrap (
 
 import Propellor
 import qualified Propellor.Property.Apt as Apt
+import Propellor.Property.Chroot.Util
 import Utility.Path
 import Utility.SafeCommand
 import Utility.FileMode
@@ -78,7 +79,8 @@ built target system@(System _ arch) config =
 			, Param target
 			]
 		cmd <- fromMaybe "debootstrap" <$> programPath
-		ifM (boolSystem cmd params)
+		de <- standardPathEnv
+		ifM (boolSystemEnv cmd params (Just de))
 			( do
 				fixForeignDev target
 				return MadeChange
@@ -141,8 +143,26 @@ installed = RevertableProperty install remove
 	aptremove = Apt.removed ["debootstrap"]
 
 sourceInstall :: Property
-sourceInstall = property "debootstrap installed from source"
+sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
-	(liftIO sourceInstall')
+	`requires` perlInstalled
+	`requires` arInstalled
+
+perlInstalled :: Property
+perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ do
+	v <- liftIO $ firstM id
+		[ yumInstall "perl"
+		]
+	if isJust v then return MadeChange else return FailedChange
+
+arInstalled :: Property
+arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ do
+	v <- liftIO $ firstM id
+		[ yumInstall "binutils"
+		]
+	if isJust v then return MadeChange else return FailedChange
+
+yumInstall :: String -> IO Bool
+yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p]
 
 sourceInstall' :: IO Result
 sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
@@ -228,18 +248,23 @@ makeDevicesTarball = do
 	tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz"
 
 fixForeignDev :: FilePath -> IO ()
-fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ 
+fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do
-	void $ boolSystem "chroot"
+	de <- standardPathEnv
+	void $ boolSystemEnv "chroot"
 		[ File target
 		, Param "sh"
 		, Param "-c"
 		, Param $ intercalate " && "
-			[ "rm -rf /dev"
+			[ "apt-get update"
+			, "apt-get -y install makedev"
+			, "rm -rf /dev"
 			, "mkdir /dev"
 			, "cd /dev"
+			, "mount -t proc proc /proc"
 			, "/sbin/MAKEDEV std ptmx fd consoleonly"
 			]
 		]
+		(Just de)
 
 foreignDevFlag :: FilePath
 foreignDevFlag = "/dev/.propellor-foreign-dev"

src/Propellor/Property/Docker.hs

@@ -377,7 +377,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 		liftIO $ do
 			clearProvisionedFlag cid
 			createDirectoryIfMissing True (takeDirectory $ identFile cid)
-		shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
+		shim <- liftIO $ Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
 		liftIO $ writeFile (identFile cid) (show ident)
 		ensureProperty $ boolProperty "run" $ runContainer img
 			(runps ++ ["-i", "-d", "-t"])

src/Propellor/Property/Git.hs

@@ -57,8 +57,9 @@ type Branch = String
 
 -- | Specified git repository is cloned to the specified directory.
 --
--- If the firectory exists with some other content, it will be recursively
+-- If the directory exists with some other content (either a non-git
--- deleted.
+-- repository, or a git repository cloned from some other location),
+-- it will be recursively deleted first.
 --
 -- A branch can be specified, to check out.
 cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
@@ -94,3 +95,23 @@ cloned owner url dir mbranch = check originurl (property desc checkout)
 
 isGitDir :: FilePath -> IO Bool
 isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir])
+
+data GitShared = Shared GroupName | SharedAll | NotShared
+
+bareRepo :: FilePath -> UserName -> GitShared -> Property
+bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
+	dirExists repo : case gitshared of
+		NotShared ->
+			[ ownerGroup repo user user
+			, userScriptProperty user ["git", "init", "--bare", "--shared=false", repo]
+			]
+		SharedAll ->
+			[ ownerGroup repo user user
+			, userScriptProperty user ["git", "init", "--bare", "--shared=all", repo]
+			]
+		Shared group' ->
+			[ ownerGroup repo user group'
+			, userScriptProperty user ["git", "init", "--bare", "--shared=group", repo]
+			]
+  where
+	isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])

src/Propellor/Property/Group.hs

@@ -0,0 +1,14 @@
+module Propellor.Property.Group where
+
+import Propellor
+
+type GID = Int
+
+exists :: GroupName -> Maybe GID -> Property
+exists group' mgid = check test (cmdProperty "addgroup" $ args mgid)
+	`describe` unwords ["group", group']
+  where
+	groupFile = "/etc/group"
+	test = not <$> elem group' <$> words <$> readProcess "cut" ["-d:", "-f1", groupFile]
+	args Nothing = [group']
+	args (Just gid) = ["--gid", show gid, group']

src/Propellor/Property/User.hs

@@ -30,7 +30,7 @@ hasSomePassword user context = check ((/= HasPassword) <$> getPasswordStatus use
 
 hasPassword :: UserName -> Context -> Property
 hasPassword user context = withPrivData (Password user) context $ \getpassword ->
-	property (user ++ " has password") $ 
+	property (user ++ " has password") $
 		getpassword $ \password -> makeChange $
 			withHandle StdinHandle createProcessSuccess
 				(proc "chpasswd" []) $ \h -> do
@@ -60,3 +60,12 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
 
 homedir :: UserName -> IO FilePath
 homedir user = homeDirectory <$> getUserEntryForName user
+
+hasGroup :: UserName -> GroupName -> Property
+hasGroup user group' = check test $ cmdProperty "adduser"
+	[ user
+	, group'
+	]
+	`describe` unwords ["user", user, "in group", group']
+  where
+	test = not . elem group' . words <$> readProcess "groups" [user]

src/Propellor/Shim.hs

@@ -11,14 +11,18 @@ import Utility.LinuxMkLibs
 import Utility.SafeCommand
 import Utility.Path
 import Utility.FileMode
+import Utility.FileSystemEncoding
 
 import Data.List
 import System.Posix.Files
 
 -- | Sets up a shimmed version of the program, in a directory, and
 -- returns its path.
-setup :: FilePath -> FilePath -> IO FilePath
+--
-setup propellorbin dest = do
+-- Propellor may be running from an existing shim, in which case it's
+-- simply reused.
+setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath
+setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
 	createDirectoryIfMissing True dest
 
 	libs <- parseLdd <$> readProcess "ldd" [propellorbin]
@@ -36,15 +40,26 @@ setup propellorbin dest = do
 	let linkerparams = ["--library-path", intercalate ":" libdirs ]
 	let shim = file propellorbin dest
 	writeFile shim $ unlines
-		[ "#!/bin/sh"
+		[ shebang
 		, "GCONV_PATH=" ++ shellEscape gconvdir
 		, "export GCONV_PATH"
 		, "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ 
-			" " ++ shellEscape propellorbin ++ " \"$@\""
+			" " ++ shellEscape (fromMaybe propellorbin propellorbinpath) ++ " \"$@\""
 		]
 	modifyFileMode shim (addModes executeModes)
 	return shim
 
+shebang :: String
+shebang = "#!/bin/sh"
+
+checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath
+checkAlreadyShimmed f nope = withFile f ReadMode $ \h -> do
+	fileEncoding h
+	s <- hGetLine h
+	if s == shebang
+		then return f
+		else nope
+
 -- Called when the shimmed propellor is running, so that commands it runs
 -- don't see it.
 cleanEnv :: IO ()

src/Propellor/Spin.hs

@@ -1,10 +1,6 @@
--- When propellor --spin is running, the local host acts as a server,
+module Propellor.Spin (
--- which connects to the remote host's propellor and responds to its
+	spin,
--- requests.
-
-module Propellor.Server (
 	update,
-	updateServer,
 	gitPushHelper
 ) where
 
@@ -22,21 +18,83 @@ import Propellor.Protocol
 import Propellor.PrivData.Paths
 import Propellor.Git
 import Propellor.Ssh
+import Propellor.Gpg
 import qualified Propellor.Shim as Shim
 import Utility.FileMode
 import Utility.SafeCommand
 
+spin :: HostName -> Maybe HostName -> Host -> IO ()
+spin target relay hst = do
+	unless relaying $ 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 <- if viarelay
+		then pure ["-A"]
+		else toCommand <$> sshCachingParams hn
+	when viarelay $
+		void $ boolSystem "ssh-add" []
+
+	-- Install, or update the remote propellor.
+	updateServer target relay hst
+		(proc "ssh" $ cacheparams ++ [user, shellWrap probecmd])
+		(proc "ssh" $ cacheparams ++ [user, shellWrap updatecmd])
+
+	-- And now we can run it.
+	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, shellWrap runcmd])) $
+		error $ "remote propellor failed"
+  where
+	hn = fromMaybe target relay
+	user = "root@"++hn
+
+	relaying = relay == Just target
+	viarelay = isJust relay && not relaying
+
+	probecmd = intercalate " ; "
+		[ "if [ ! -d " ++ localdir ++ "/.git ]"
+		, "then (" ++ intercalate " && "
+			[ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi"
+			, "echo " ++ toMarked statusMarker (show NeedGitClone)
+			] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
+		, "else " ++ updatecmd
+		, "fi"
+		]
+	
+	updatecmd = intercalate " && "
+		[ "cd " ++ localdir
+		, "if ! test -x ./propellor; then make deps build; fi"
+		, if viarelay
+			then "./propellor --continue " ++
+				shellEscape (show (Update (Just target)))
+			-- Still using --boot for back-compat...
+			else "./propellor --boot " ++ target
+		]
+
+	runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd
+	cmd = if viarelay
+		then "--serialized " ++ shellEscape (show (Spin target (Just target)))
+		else "--continue " ++ shellEscape (show (SimpleRun target))
+
 -- Update the privdata, repo url, and git repo over the ssh
 -- connection, talking to the user's local propellor instance which is
 -- running the updateServer
-update :: IO ()
+update :: Maybe HostName -> IO ()
-update = do
+update forhost = do
-	whenM hasOrigin $
+	whenM hasGitRepo $
 		req NeedRepoUrl repoUrlMarker setRepoUrl
+
 	makePrivDataDir
+	createDirectoryIfMissing True (takeDirectory privfile)
 	req NeedPrivData privDataMarker $
-		writeFileProtected privDataLocal
+		writeFileProtected privfile
-	whenM hasOrigin $
+
+	whenM hasGitRepo $
 		req NeedGitPush gitPushMarker $ \_ -> do
 			hin <- dup stdInput
 			hout <- dup stdOutput
@@ -52,48 +110,70 @@ update = do
 		, 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
 
--- The connect action should ssh to the remote host and run the provided
+updateServer
--- calback action.
+	:: HostName
-updateServer :: HostName  -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
+	-> Maybe HostName
-updateServer hn hst connect = connect go
+	-> Host
+	-> CreateProcess
+	-> CreateProcess
+	-> IO ()
+updateServer target relay hst connect haveprecompiled =
+	withBothHandles createProcessSuccess connect go
   where
+	hn = fromMaybe target relay
+	relaying = relay == Just target
+
 	go (toh, fromh) = do
 		let loop = go (toh, fromh)
+		let restart = updateServer hn relay hst connect haveprecompiled
+		let done = return ()
 		v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
 		case v of
 			(Just NeedRepoUrl) -> do
 				sendRepoUrl toh
 				loop
 			(Just NeedPrivData) -> do
-				sendPrivData hn hst toh
+				sendPrivData hn hst toh relaying
 				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
+				restart
 			(Just NeedPrecompiled) -> do
 				hClose toh
 				hClose fromh
 				sendPrecompiled hn
-				updateServer hn hst connect
+				updateServer hn relay hst haveprecompiled (error "loop")
-			Nothing -> return ()
+			(Just NeedGitPush) -> do
+				sendGitUpdate hn fromh toh
+				hClose fromh
+				hClose toh
+				done
+			Nothing -> done
 
 sendRepoUrl :: Handle -> IO ()
 sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
 
-sendPrivData :: HostName -> Host -> Handle -> IO ()
+sendPrivData :: HostName -> Host -> Handle -> Bool -> IO ()
-sendPrivData hn hst toh = do
+sendPrivData hn hst toh relaying = do
-	privdata <- show . filterPrivData hst <$> decryptPrivData
+	privdata <- getdata
 	void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
 		sendMarked toh privDataMarker privdata
 		return True
+  where
+	getdata
+		| relaying = do
+			let f = privDataRelay hn
+			d <- readFileStrictAnyEncoding f
+			nukeFile f
+			return d
+		| otherwise = show . filterPrivData hst <$> decryptPrivData
 
 sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
 sendGitUpdate hn fromh toh =
@@ -141,9 +221,12 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor
 		createDirectoryIfMissing True (tmpdir </> shimdir)
 		changeWorkingDirectory (tmpdir </> shimdir)
 		me <- readSymbolicLink "/proc/self/exe"
-		shim <- Shim.setup me "."
+		createDirectoryIfMissing True "bin"
-		when (shim /= "propellor") $
+		unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $
-			renameFile shim "propellor"
+			errorMessage "failed copying in propellor"
+		let bin = "bin/propellor"
+		let binpath = Just $ localdir </> bin
+		void $ Shim.setup bin binpath "."
 		changeWorkingDirectory tmpdir
 		withTmpFile "propellor.tar." $ \tarball _ -> allM id
 			[ boolSystem "strip" [File me]

src/Propellor/Ssh.hs

@@ -20,8 +20,9 @@ sshCachingParams hn = do
 	let cachedir = home </> ".ssh" </> "propellor"
 	createDirectoryIfMissing False cachedir
 	let socketfile = cachedir </> hn ++ ".sock"
-	let ps = 
+	let ps =
-		[ Param "-o", Param ("ControlPath=" ++ socketfile)
+		[ Param "-o"
+		, Param ("ControlPath=" ++ socketfile)
 		, Params "-o ControlMaster=auto -o ControlPersist=yes"
 		]
 

src/Propellor/Types.hs

@@ -142,15 +142,16 @@ instance ActionResult Result where
 
 data CmdLine
 	= Run HostName
-	| Spin HostName
+	| Spin HostName (Maybe HostName)
 	| SimpleRun HostName
 	| Set PrivDataField Context
 	| Dump PrivDataField Context
 	| Edit PrivDataField Context
 	| ListFields
 	| AddKey String
+	| Serialized CmdLine
 	| Continue CmdLine
-	| Update HostName
+	| Update (Maybe HostName)
 	| DockerInit HostName
 	| DockerChain HostName String
 	| ChrootChain HostName FilePath Bool Bool

src/Propellor/Types/OS.hs

@@ -1,6 +1,17 @@
-module Propellor.Types.OS where
+module Propellor.Types.OS (
+	HostName,
+	UserName,
+	GroupName,
+	System(..),
+	Distribution(..),
+	DebianSuite(..),
+	isStable,
+	Release,
+	Architecture,
+) where
+
+import Network.BSD (HostName)
 
-type HostName = String
 type UserName = String
 type GroupName = String