diff --git a/.gitignore b/.gitignore index e992550..a2d84e4 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ Setup Setup.hi Setup.o docker +propellor.1 diff --git a/config-joey.hs b/config-joey.hs index 3555d83..b6152f1 100644 --- a/config-joey.hs +++ b/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 -testChroot = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty "/tmp/chroot" - & File.hasContent "/foo" ["hello"] + +alien :: Host +alien = host "alientest.kitenet.net" + & 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" diff --git a/debian/changelog b/debian/changelog index a44d72a..2c3baf8 100644 --- a/debian/changelog +++ b/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 - host, which handles any necessary provisioning of the host being spun. + * --spin target --via relay causes propellor to bounce through an + 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 Sat, 22 Nov 2014 00:12:35 -0400 diff --git a/doc/usage.mdwn b/doc/usage.mdwn index 4279704..6646ab1 100644 --- a/doc/usage.mdwn +++ b/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, - or if it's already installed there, push any updates. Propellor is then - run on the host, to satisfy its configured properties. + Causes propellor to automatically install itself on the specified target + host, or if it's already installed there, push any updates. Propellor is + 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 diff --git a/propellor.cabal b/propellor.cabal index 9fe7a26..cd34d4b 100644 --- a/propellor.cabal +++ b/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 diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index ec2ca7e..f5cfc78 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) diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index b551ca0..0b65fb7 100644 --- a/src/Propellor/Engine.hs +++ b/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 diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs index e5f464c..ccf97b9 100644 --- a/src/Propellor/Git.hs +++ b/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. diff --git a/src/Propellor/PrivData/Paths.hs b/src/Propellor/PrivData/Paths.hs index 7c29f1b..3d0d8a5 100644 --- a/src/Propellor/PrivData/Paths.hs +++ b/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 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index c3b14a8..3da8b0d 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/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 diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs new file mode 100644 index 0000000..feb71d0 --- /dev/null +++ b/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" diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 0611e73..ab5bddf 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/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" - (liftIO sourceInstall') +sourceInstall = property "debootstrap installed from source" (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)) $ - void $ boolSystem "chroot" +fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do + 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" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 460bc3e..586ebc2 100644 --- a/src/Propellor/Property/Docker.hs +++ b/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"]) diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index 8d49cbd..eb7801c 100644 --- a/src/Propellor/Property/Git.hs +++ b/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 --- deleted. +-- If the directory exists with some other content (either a non-git +-- 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']) diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs new file mode 100644 index 0000000..f03510c --- /dev/null +++ b/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'] diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index f9c400a..6a51703 100644 --- a/src/Propellor/Property/User.hs +++ b/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] diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index 1bfbb0c..a97bf5c 100644 --- a/src/Propellor/Shim.hs +++ b/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 () diff --git a/src/Propellor/Server.hs b/src/Propellor/Spin.hs similarity index 58% rename from src/Propellor/Server.hs rename to src/Propellor/Spin.hs index 19a2c90..06bac33 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Spin.hs @@ -1,10 +1,6 @@ --- When propellor --spin is running, the local host acts as a server, --- which connects to the remote host's propellor and responds to its --- requests. - -module Propellor.Server ( +module Propellor.Spin ( + spin, 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 = do - whenM hasOrigin $ +update :: Maybe HostName -> IO () +update forhost = do + whenM hasGitRepo $ req NeedRepoUrl repoUrlMarker setRepoUrl + makePrivDataDir + createDirectoryIfMissing True (takeDirectory privfile) req NeedPrivData privDataMarker $ - writeFileProtected privDataLocal - whenM hasOrigin $ + writeFileProtected privfile + + 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 --- calback action. -updateServer :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO () -updateServer hn hst connect = connect go +updateServer + :: HostName + -> Maybe HostName + -> 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 - Nothing -> return () + updateServer hn relay hst haveprecompiled (error "loop") + (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 hn hst toh = do - privdata <- show . filterPrivData hst <$> decryptPrivData +sendPrivData :: HostName -> Host -> Handle -> Bool -> IO () +sendPrivData hn hst toh relaying = do + 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 "." - when (shim /= "propellor") $ - renameFile shim "propellor" + createDirectoryIfMissing True "bin" + unlessM (boolSystem "cp" [File me, File "bin/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] diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs index 969517a..97c3eb6 100644 --- a/src/Propellor/Ssh.hs +++ b/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 = - [ Param "-o", Param ("ControlPath=" ++ socketfile) + let ps = + [ Param "-o" + , Param ("ControlPath=" ++ socketfile) , Params "-o ControlMaster=auto -o ControlPersist=yes" ] diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e7d6354..949ce4b 100644 --- a/src/Propellor/Types.hs +++ b/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 diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs index 2529e7d..72e3d76 100644 --- a/src/Propellor/Types/OS.hs +++ b/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