summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-11-23 14:41:09 -0400
committerJoey Hess2014-11-23 14:41:09 -0400
commitac41f8b07b45b1855b1c10665757691a56b08353 (patch)
treed446f81a4068ca594abd881c2b055ad2f8662a12
parent1b34f23414b574105ddfdf36fbeb86aa115a0e2e (diff)
parent3c952a0de9d228eafe6e208007be7d2e018d68b8 (diff)
Merge branch 'joeyconfig'
-rw-r--r--.gitignore1
-rw-r--r--config-joey.hs17
-rw-r--r--debian/changelog9
-rw-r--r--doc/usage.mdwn22
-rw-r--r--propellor.cabal4
-rw-r--r--src/Propellor/CmdLine.hs85
-rw-r--r--src/Propellor/Engine.hs3
-rw-r--r--src/Propellor/Git.hs3
-rw-r--r--src/Propellor/PrivData/Paths.hs3
-rw-r--r--src/Propellor/Property/Chroot.hs7
-rw-r--r--src/Propellor/Property/Chroot/Util.hs15
-rw-r--r--src/Propellor/Property/Debootstrap.hs37
-rw-r--r--src/Propellor/Property/Docker.hs2
-rw-r--r--src/Propellor/Property/Git.hs25
-rw-r--r--src/Propellor/Property/Group.hs14
-rw-r--r--src/Propellor/Property/User.hs11
-rw-r--r--src/Propellor/Shim.hs23
-rw-r--r--src/Propellor/Spin.hs (renamed from src/Propellor/Server.hs)143
-rw-r--r--src/Propellor/Ssh.hs5
-rw-r--r--src/Propellor/Types.hs5
-rw-r--r--src/Propellor/Types/OS.hs15
21 files changed, 326 insertions, 123 deletions
diff --git a/.gitignore b/.gitignore
index e9925509..a2d84e4e 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 3555d831..b6152f15 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 a44d72af..2c3baf81 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 <joeyh@debian.org> Sat, 22 Nov 2014 00:12:35 -0400
diff --git a/doc/usage.mdwn b/doc/usage.mdwn
index 42797049..6646ab14 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 9fe7a26f..cd34d4bf 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 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)
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index b551ca05..0b65fb7e 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 e5f464c0..ccf97b94 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 7c29f1bf..3d0d8a58 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 c3b14a8e..3da8b0d6 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 00000000..feb71d01
--- /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 0611e735..ab5bddf4 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 460bc3ec..586ebc2e 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 8d49cbd0..eb7801c1 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 00000000..f03510cf
--- /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 f9c400a8..6a51703a 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 1bfbb0ca..a97bf5c8 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
index 19a2c901..06bac330 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 969517a8..97c3eb6d 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 e7d63547..949ce4b7 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 2529e7d8..72e3d764 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