summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Bootstrap.hs
blob: 6158d9677be570510c66986a018deec0f7dca342 (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
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 ++ ")")