added Propellor.Property.Bootstrap (untested)

This commit was sponsored by Jake Vosloo on Patreon.

5 files changed, 116 insertions, 1 deletions

diff --git a/doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment b/doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment
new file mode 100644
index 00000000..5a826fea
--- /dev/null
+++ b/doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment
@@ -0,0 +1,16 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2017-04-09T17:42:10Z"
+ content="""
+Making this work when propellor is setting up a chroot is difficult,
+because the localdir is bind mounted into the chroot.
+
+Hmm, `unshare` could be helpful. Run shell commands to clone the localdir
+inside `unshare -m`, prefixed with a `umount localdir`. This way, the bind
+mount is avoided, and it writes "under" it. Limits the commands that can be
+run to set up the localdir to shell commands, but bootstrap already
+operates on terms of shell commands so that seems ok.
+
+`unshare` is linux-specific; comes in util-linux on modern linuxes.
+"""]]
diff --git a/joeyconfig.hs b/joeyconfig.hs
index e73897b4..036c2c92 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -38,6 +38,7 @@ import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuil
 import qualified Propellor.Property.SiteSpecific.Branchable as Branchable
 import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
 import Propellor.Property.DiskImage
+import Propellor.Property.Bootstrap
 
 main :: IO ()           --     _         ______`|                       ,-.__
 main = defaultMain hosts --  /   \___-=O`/|O`/__|                      (____.'
@@ -93,7 +94,7 @@ darkstar = host "darkstar.kitenet.net" $ props
 		[ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar")
 		]
 
-	! imageBuilt "/tmp/img" c MSDOS (grubBooted PC)
+	& imageBuilt "/tmp/img" c MSDOS (grubBooted PC)
 		[ partition EXT2 `mountedAt` "/boot"
 			`setFlag` BootFlag
 		, partition EXT4 `mountedAt` "/"
@@ -106,6 +107,7 @@ darkstar = host "darkstar.kitenet.net" $ props
 		& Hostname.setTo "demo"
 		& Apt.installed ["linux-image-amd64"]
 		& User "root" `User.hasInsecurePassword` "root"
+		& bootstrappedFrom GitRepoOutsideChroot
 
 gnu :: Host
 gnu = host "gnu.kitenet.net" $ props
diff --git a/propellor.cabal b/propellor.cabal
index a04089b5..f4a1f23a 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -87,6 +87,7 @@ Library
     Propellor.Property.Apt
     Propellor.Property.Apt.PPA
     Propellor.Property.Attic
+    Propellor.Property.Bootstrap
     Propellor.Property.Borg
     Propellor.Property.Ccache
     Propellor.Property.Cmd
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
new file mode 100644
index 00000000..6158d967
--- /dev/null
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -0,0 +1,95 @@
+module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where
+
+import Propellor.Base
+import Propellor.Bootstrap
+import Propellor.Property.Chroot
+
+import Data.List
+
+-- | 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 $ 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 " ++ originloc) $ do
+	ifM needclone
+		( do
+			let tmpclone = localdir ++ ".tmpclone"
+			system <- getOS
+			assumeChange $ exposeTrueLocaldir $ 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 $ buildShellCommand
+			[ "cd " ++ localdir
+			, "git pull"
+			]
+		)
+  where
+	needclone = (inChroot <&&> truelocaldirisempty)
+		<||> (liftIO (not <$> doesDirectoryExist localdir))
+	truelocaldirisempty = exposeTrueLocaldir $
+		"test ! -d " ++ localdir ++ "/.git"
+	originloc = case reposource of
+		GitRepoUrl s -> s
+		GitRepoOutsideChroot -> localdir
+
+-- | Runs the shell command with the true localdir exposed,
+-- not the one bind-mounted into a chroot.
+exposeTrueLocaldir :: String -> Propellor Bool
+exposeTrueLocaldir s = do
+	s' <- ifM inChroot
+		( return $ "unshare -m sh -c " ++ shellEscape
+			("umount " ++ localdir ++ " && ( " ++ s ++ ")")
+		, return s
+		)
+	liftIO $ boolSystem "sh" [ Param "-c", Param s']
+
+assumeChange :: Propellor Bool -> Propellor Result
+assumeChange a = do
+	ok <- a
+	return (cmdResult ok <> MadeChange)
+
+buildShellCommand :: [String] -> String
+buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")
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,