summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Bootstrap.hs
blob: 35df08e09bf190ee18e0e3d2399f1832c7ed49ed (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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
-- | This module contains properties that configure how Propellor
-- bootstraps to run itself on a Host.

module Propellor.Property.Bootstrap (
	Bootstrapper(..),
	Builder(..),
	bootstrapWith,
	RepoSource(..),
	bootstrappedFrom,
	clonedFrom
) where

import Propellor.Base
import Propellor.Bootstrap
import Propellor.Types.Info
import Propellor.Types.Container
import Propellor.Property.Chroot
import Propellor.PrivData.Paths

import Data.List
import qualified Data.ByteString as B

-- | This property can be used to configure the `Bootstrapper` that is used
-- to bootstrap propellor on a Host. For example, if you want to use
-- stack:
--
-- > host "example.com" $ props
-- > 	& bootstrapWith (Robustly Stack)
--
-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`, 
-- this property can also be added to the chroot to configure it.
bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
bootstrapWith b = pureInfoProperty desc (InfoVal b)
  where
	desc = "propellor bootstrapped with " ++ case b of
		Robustly Stack -> "stack"
		Robustly Cabal -> "cabal"
		OSOnly -> "OS packages only"

-- | Where a propellor repository should be bootstrapped from.
data RepoSource
	= GitRepoUrl String
	| GitRepoOutsideChroot
	-- ^ When used in a chroot, this copies the git repository from
	-- outside the chroot, including its configuration.

-- | Bootstraps a propellor installation into
-- /usr/local/propellor/
--
-- Normally, propellor is bootstrapped by eg, using propellor --spin,
-- and so this property is not generally needed.
--
-- This property only does anything when used inside a Chroot or other
-- Container. This is particularly 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 or stack.
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom reposource = check (hasContainerCapability FilesystemContained) $
	go `requires` clonedFrom reposource
  where
	go :: Property Linux
	go = property "Propellor bootstrapped" $ do
		system <- getOS
		-- gets Host value representing the chroot this is run in
		chroothost <- ask
		-- load privdata from outside the chroot, and filter
		-- to only the privdata needed inside the chroot.
		privdata <- liftIO $ filterPrivData chroothost
			<$> readPrivDataFile privDataLocal
		bootstrapper <- getBootstrapper
		assumeChange $ exposeTrueLocaldir $ const $ do
			liftIO $ createDirectoryIfMissing True $
				takeDirectory privDataLocal
			liftIO $ writeFileProtected privDataLocal $
				show privdata
			runShellCommand $ buildShellCommand
				[ "cd " ++ localdir
				, checkDepsCommand bootstrapper system
				, buildCommand bootstrapper
				]

-- | Clones the propellor repository into /usr/local/propellor/
--
-- If the propellor repo has already been cloned, pulls to get it
-- up-to-date.
clonedFrom :: RepoSource -> Property Linux
clonedFrom reposource = case reposource of
	GitRepoOutsideChroot -> go `onChange` copygitconfig
	_ -> go
  where
	go :: Property Linux
	go = property ("Propellor repo cloned from " ++ sourcedesc) $
		ifM needclone (makeclone, updateclone)
	
	makeclone = 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
				]
	
	updateclone = assumeChange $ exposeTrueLocaldir $ const $
		runShellCommand $ buildShellCommand
			[ "cd " ++ localdir
			, "git pull"
			]
	
	-- Copy the git config of the repo outside the chroot into the
	-- chroot. This way it has the same remote urls, and other git
	-- configuration.
	copygitconfig :: Property Linux
	copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do
		let gitconfig = localdir </> ".git" </> "config"
		cfg <- liftIO $ B.readFile gitconfig
		exposeTrueLocaldir $ const $
			liftIO $ B.writeFile gitconfig cfg
		return MadeChange

	needclone = (hasContainerCapability FilesystemContained <&&> truelocaldirisempty)
		<||> (liftIO (not <$> doesDirectoryExist localdir))
	
	truelocaldirisempty = exposeTrueLocaldir $ const $
		runShellCommand ("test ! -d " ++ localdir ++ "/.git")

	sourcedesc = case reposource of
		GitRepoUrl s -> s
		GitRepoOutsideChroot -> localdir ++ " outside the chroot"

assumeChange :: Propellor Bool -> Propellor Result
assumeChange a = do
	ok <- a
	return (cmdResult ok <> MadeChange)

buildShellCommand :: [String] -> String
buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")

runShellCommand :: String -> Propellor Bool
runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s]