summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs2
-rw-r--r--src/Propellor/Property/Bootstrap.hs126
-rw-r--r--src/Propellor/Property/Cmd.hs1
-rw-r--r--src/Propellor/Spin.hs2
4 files changed, 129 insertions, 2 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 9d2d603d..29c55213 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -144,7 +144,7 @@ installGitCommand msys = case msys of
-- assume a debian derived system when not specified
Nothing -> use apt
where
- use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi"
+ use cmds = "if ! git --version >/dev/null 2>&1; then " ++ intercalate " && " cmds ++ "; fi"
apt =
[ "apt-get update"
, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
new file mode 100644
index 00000000..5f64fd69
--- /dev/null
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -0,0 +1,126 @@
+module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where
+
+import Propellor.Base
+import Propellor.Bootstrap
+import Propellor.Property.Chroot
+
+import Data.List
+import System.Posix.Directory
+
+-- | Where a propellor repository should be bootstrapped from.
+data RepoSource
+ = GitRepoUrl String
+ | GitRepoOutsideChroot
+
+-- | Bootstraps a propellor installation into
+-- /usr/local/propellor/
+--
+-- Normally, propellor is already bootstrapped when it runs, so this
+-- property is not useful. However, this can be useful inside a
+-- chroot used to build a disk image, to make the disk image
+-- have propellor installed.
+--
+-- The git repository is cloned (or pulled to update if it already exists).
+--
+-- All build dependencies are installed, using distribution packages
+-- or falling back to using cabal.
+bootstrappedFrom :: RepoSource -> Property Linux
+bootstrappedFrom reposource = go `requires` clonedFrom reposource
+ where
+ go :: Property Linux
+ go = property "Propellor bootstrapped" $ do
+ system <- getOS
+ assumeChange $ exposeTrueLocaldir $ const $
+ runShellCommand $ buildShellCommand
+ [ "cd " ++ localdir
+ , bootstrapPropellorCommand system
+ ]
+
+-- | Clones the propellor repeository into /usr/local/propellor/
+--
+-- GitRepoOutsideChroot can be used when this is used in a chroot.
+-- In that case, it clones the /usr/local/propellor/ from outside the
+-- chroot into the same path inside the chroot.
+--
+-- If the propellor repo has already been cloned, pulls to get it
+-- up-to-date.
+clonedFrom :: RepoSource -> Property Linux
+clonedFrom reposource = property ("Propellor repo cloned from " ++ sourcedesc) $ do
+ ifM needclone
+ ( do
+ let tmpclone = localdir ++ ".tmpclone"
+ system <- getOS
+ assumeChange $ exposeTrueLocaldir $ \sysdir -> do
+ let originloc = case reposource of
+ GitRepoUrl s -> s
+ GitRepoOutsideChroot -> sysdir
+ runShellCommand $ buildShellCommand
+ [ installGitCommand system
+ , "rm -rf " ++ tmpclone
+ , "git clone " ++ shellEscape originloc ++ " " ++ tmpclone
+ , "mkdir -p " ++ localdir
+ -- This is done rather than deleting
+ -- the old localdir, because if it is bound
+ -- mounted from outside the chroot, deleting
+ -- it after unmounting in unshare will remove
+ -- the bind mount outside the unshare.
+ , "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)"
+ , "rm -rf " ++ tmpclone
+ ]
+ , assumeChange $ exposeTrueLocaldir $ const $
+ runShellCommand $ buildShellCommand
+ [ "cd " ++ localdir
+ , "git pull"
+ ]
+ )
+ where
+ needclone = (inChroot <&&> truelocaldirisempty)
+ <||> (liftIO (not <$> doesDirectoryExist localdir))
+ truelocaldirisempty = exposeTrueLocaldir $ const $
+ runShellCommand ("test ! -d " ++ localdir ++ "/.git")
+ sourcedesc = case reposource of
+ GitRepoUrl s -> s
+ GitRepoOutsideChroot -> localdir
+
+-- | Runs an action with the true localdir exposed,
+-- not the one bind-mounted into a chroot. The action is passed the
+-- path containing the contents of the localdir outside the chroot.
+--
+-- In a chroot, this is accomplished by temporily bind mounting the localdir
+-- to a temp directory, to preserve access to the original bind mount. Then
+-- we unmount the localdir to expose the true localdir. Finally, to cleanup,
+-- the temp directory is bind mounted back to the localdir.
+exposeTrueLocaldir :: (FilePath -> IO a) -> Propellor a
+exposeTrueLocaldir a = ifM inChroot
+ ( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir ->
+ bracket_
+ (movebindmount localdir tmpdir)
+ (movebindmount tmpdir localdir)
+ (a tmpdir)
+ , liftIO $ a localdir
+ )
+ where
+ movebindmount from to = do
+ run "mount" [Param "--bind", File from, File to]
+ -- Have to lazy unmount, because the propellor process
+ -- is running in the localdir that it's unmounting..
+ run "umount" [Param "-l", File from]
+ -- We were in the old localdir; move to the new one after
+ -- flipping the bind mounts. Otherwise, commands that try
+ -- to access the cwd will fail because it got umounted out
+ -- from under.
+ changeWorkingDirectory "/"
+ changeWorkingDirectory localdir
+ run cmd ps = unlessM (boolSystem cmd ps) $
+ error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
+
+assumeChange :: Propellor Bool -> Propellor Result
+assumeChange a = do
+ ok <- a
+ return (cmdResult ok <> MadeChange)
+
+buildShellCommand :: [String] -> String
+buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")
+
+runShellCommand :: String -> IO Bool
+runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s]
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 6b84acb5..f2de1a27 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -33,6 +33,7 @@ module Propellor.Property.Cmd (
Script,
scriptProperty,
userScriptProperty,
+ cmdResult,
-- * Lower-level interface for running commands
CommandParam(..),
boolSystem,
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 447f8e9f..3b3729f9 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -87,7 +87,7 @@ spin' mprivdata relay target hst = do
-- And now we can run it.
unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
- error "remote propellor failed"
+ giveup "remote propellor failed"
where
hn = fromMaybe target relay
sys = case fromInfo (hostInfo hst) of