summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Bootstrap.hs
blob: 5f64fd690cf829475421feb1975c7f9b382da799 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
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]