summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Sbuild.hs
blob: 2647e69efac52982427519537e8302278db16231 (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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE TypeFamilies #-}

{-|
Maintainer: Sean Whitton <spwhitton@spwhitton.name>

Build and maintain schroots for use with sbuild.

Suggested usage in @config.hs@:

>  & Apt.installed ["piuparts"]
>  & Sbuild.builtFor (System (Debian Unstable) "i386")
>  & Sbuild.piupartsConfFor (System (Debian Unstable) "i386")
>  & Sbuild.updatedFor (System (Debian Unstable) "i386") `period` Weekly 1
>  & Sbuild.usableBy (User "spwhitton")
>  & Sbuild.shareAptCache
>  & Schroot.overlaysInTmpfs

In @~/.sbuildrc@:

>  $run_piuparts = 1;
>  $piuparts_opts = [
>      '--schroot',
>      'unstable-i386-piuparts',
>      '--fail-if-inadequate',
>      '--fail-on-broken-symlinks',
>      ];
>
>  $external_commands = {
>    'post-build-commands' => [
>      [
>        'adt-run',
>        '--changes', '%c',
>        '---',
>        'schroot', 'unstable-i386-sbuild;',
>
>        # if adt-run's exit code is 8 then the package had no tests but
>        # this isn't a failure, so catch it
>        'adtexit=$?;',
>        'if', 'test', '$adtexit', '=', '8;', 'then',
>        'exit', '0;', 'else', 'exit', '$adtexit;', 'fi'
>      ],
>    ],
>  };

We use @sbuild-createchroot(1)@ to create a chroot to the specification of
@sbuild-setup(7)@.  This differs from the approach taken by picca's Sbuild.hs,
which uses 'Propellor.Property.Debootstrap' to construct the chroot.  This is
because we don't want to run propellor inside the chroot in order to keep the
sbuild environment as standard as possible.
-}

-- If you wanted to do it with Propellor.Property.Debootstrap, note that
-- sbuild-createchroot has a --setup-only option

module Propellor.Property.Sbuild (
	-- * Creating and updating sbuild schroots
	SbuildSchroot(..),
	builtFor,
	built,
	updated,
	updatedFor,
	piupartsConfFor,
	piupartsConf,
	-- * Global sbuild configuration
	-- blockNetwork,
	installed,
	keypairGenerated,
	shareAptCache,
	usableBy,
) where

import Propellor.Base
import Propellor.Property.Debootstrap (extractSuite)
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Ccache as Ccache
import qualified Propellor.Property.ConfFile as ConfFile
import qualified Propellor.Property.File as File
-- import qualified Propellor.Property.Firewall as Firewall
import qualified Propellor.Property.User as User

import Utility.FileMode
import Data.List
import Data.List.Utils

type Suite = String

-- | An sbuild schroot, such as would be listed by @schroot -l@
--
-- Parts of the sbuild toolchain cannot distinguish between schroots with both
-- the same suite and the same architecture, so neither do we
data SbuildSchroot = SbuildSchroot Suite Architecture

instance Show SbuildSchroot where
	show (SbuildSchroot suite arch) = suite ++ "-" ++ arch

-- | Build and configure a schroot for use with sbuild using a distribution's
-- standard mirror
--
-- This function is a convenience wrapper around 'Sbuild.builtFor', allowing the
-- user to identify the schroot and distribution using the 'System' type
builtFor :: System -> RevertableProperty DebianLike UnixLike
builtFor sys = go <!> deleted
  where
	go = property' ("sbuild schroot for " ++ show sys) $
		\w -> case (schrootFromSystem sys, stdMirror sys) of
			(Just s, Just u)  -> ensureProperty w $
				setupRevertableProperty $ built s u
			_ -> errorMessage
				("don't know how to debootstrap " ++ show sys)
	deleted = property' ("no sbuild schroot for " ++ show sys) $
		\w -> case schrootFromSystem sys of
			Just s  -> ensureProperty w $
				undoRevertableProperty $ built s "dummy"
			Nothing -> noChange

-- | Build and configure a schroot for use with sbuild
built :: SbuildSchroot -> Apt.Url -> RevertableProperty DebianLike UnixLike
built s@(SbuildSchroot suite arch) mirror =
	(go
	`requires` keypairGenerated
	`requires` ccachePrepared
	`requires` installed)
	<!> deleted
  where
	go :: Property DebianLike
	go = check (unpopulated (schrootRoot s) <||> ispartial) $
		property' ("built sbuild schroot for " ++ show s) make
	make w = do
		de <- liftIO standardPathEnv
		let params = Param <$>
			[ "--arch=" ++ arch
			, "--chroot-suffix=-propellor"
			, "--include=eatmydata,ccache"
			, suite
			, schrootRoot s
			, mirror
			]
		ifM (liftIO $
			boolSystemEnv "sbuild-createchroot" params (Just de))
			( ensureProperty w $
				fixConfFile s
				`before` aliasesLine
				`before` commandPrefix
			, return FailedChange
			)
	deleted = check (not <$> unpopulated (schrootRoot s)) $
		property ("no sbuild schroot for " ++ show s) $ do
			liftIO $ removeChroot $ schrootRoot s
			liftIO $ nukeFile
				("/etc/sbuild/chroot" </> show s ++ "-sbuild")
			makeChange $ nukeFile (schrootConf s)

	-- if we're building a sid chroot, add useful aliases
	aliasesLine :: Property UnixLike
	aliasesLine = if suite == "unstable"
		then File.containsLine (schrootConf s)
			"aliases=UNRELEASED,sid,rc-buggy,experimental"
		else doNothing
	-- enable ccache and eatmydata for speed
	commandPrefix = File.containsLine (schrootConf s)
		"command-prefix=/var/cache/ccache-sbuild/sbuild-setup,eatmydata"

	-- A failed debootstrap run will leave a debootstrap directory;
	-- recover by deleting it and trying again.
	ispartial = ifM (doesDirectoryExist (schrootRoot s </> "debootstrap"))
		( do
			removeChroot $ schrootRoot s
			return True
		, return False
		)

-- | Ensure that an sbuild schroot's packages and apt indexes are updated
--
-- This function is a convenience wrapper around 'Sbuild.updated', allowing the
-- user to identify the schroot using the 'System' type
updatedFor :: System -> Property DebianLike
updatedFor system = property' ("updated sbuild schroot for " ++ show system) $
	\w -> case schrootFromSystem system of
		Just s  -> ensureProperty w $ updated s
		Nothing -> errorMessage
			("don't know how to debootstrap " ++ show system)

-- | Ensure that an sbuild schroot's packages and apt indexes are updated
updated :: SbuildSchroot -> Property DebianLike
updated s@(SbuildSchroot suite arch) =
	check (doesDirectoryExist (schrootRoot s)) $ go
	`describe` ("updated schroot for " ++ show s)
	`requires` keypairGenerated
	`requires` installed
  where
	go :: Property DebianLike
	go = tightenTargets $ cmdProperty
		"sbuild-update" ["-udr", suite ++ "-" ++ arch]
		`assume` MadeChange

-- Find the conf file that sbuild-createchroot(1) made when we passed it
-- --chroot-suffix=propellor, and edit and rename such that it is as if we
-- passed --chroot-suffix=sbuild (the default).  Replace the random suffix with
-- 'propellor'.
--
-- We had to pass --chroot-suffix=propellor in order that we can find a unique
-- config file for the schroot we just built, despite the random suffix.
--
-- The properties in this module only permit the creation of one chroot for a
-- given suite and architecture, so we don't need the suffix to be random.
fixConfFile :: SbuildSchroot -> Property UnixLike
fixConfFile s@(SbuildSchroot suite arch) =
	property' ("schroot for " ++ show s ++ " config file fixed") $ \w -> do
		confs <- liftIO $ dirContents dir
		let old = concat $ filter (tempPrefix `isPrefixOf`) confs
		liftIO $ moveFile old new
		liftIO $ moveFile
			("/etc/sbuild/chroot" </> show s ++ "-propellor")
			("/etc/sbuild/chroot" </> show s ++ "-sbuild")
		ensureProperty w $
			File.fileProperty "replace dummy suffix" (map munge) new
  where
	new = schrootConf s
	dir = takeDirectory new
	tempPrefix = dir </> suite ++ "-" ++ arch ++ "-propellor-"
	munge = replace "-propellor]" "-sbuild]"

-- | Create a corresponding schroot config file for use with piuparts
--
-- This function is a convenience wrapper around 'Sbuild.piupartsConf', allowing
-- the user to identify the schroot using the 'System' type.  See that
-- function's documentation for why you might want to use this property, and
-- sample config.
piupartsConfFor :: System -> Property DebianLike
piupartsConfFor sys = property' ("piuparts schroot conf for " ++ show sys) $
	\w -> case (schrootFromSystem sys, stdMirror sys) of
			(Just s, Just u)  -> ensureProperty w $
				piupartsConf s u
			_ -> errorMessage
				("don't know how to debootstrap " ++ show sys)

-- | Create a corresponding schroot config file for use with piuparts
--
-- This is useful because:
--
-- - piuparts will clear out the apt cache which makes 'Sbuild.shareAptCache'
--   much less useful
--
-- - piuparts itself invokes eatmydata, so the command-prefix setting in our
--   regular schroot config would force the user to pass --no-eatmydata to
--   piuparts in their @~/.sbuildrc@, which is inconvenient.
--
-- To make use of this new schroot config, you can put something like this in
-- your ~/.sbuildrc:
--
--  >  $run_piuparts = 1;
--  >  $piuparts_opts = [
--  >      '--schroot',
--  >      'unstable-i386-piuparts',
--  >      '--fail-if-inadequate',
--  >      '--fail-on-broken-symlinks',
--  >      ];
piupartsConf :: SbuildSchroot -> Apt.Url -> Property DebianLike
piupartsConf s u = go
	`requires` (setupRevertableProperty $ built s u)
	`describe` ("piuparts schroot conf for " ++ show s)
  where
	go :: Property DebianLike
	go = tightenTargets $
		check (not <$> doesFileExist f)
			(File.basedOn f (schrootConf s, map munge))
		`before`
		ConfFile.containsIniSetting f (sec, "profile", "piuparts")
		`before`
		ConfFile.containsIniSetting f (sec, "aliases", "")
		`before`
		ConfFile.containsIniSetting f (sec, "command-prefix", "")
		`before`
		File.dirExists dir
		`before`
		File.isSymlinkedTo (dir </> "copyfiles")
			(File.LinkTarget $ orig </> "copyfiles")
		`before`
		File.isSymlinkedTo (dir </> "nssdatabases")
			(File.LinkTarget $ orig </> "nssdatabases")
		`before`
		File.basedOn (dir </> "fstab")
			(orig </> "fstab", filter (/= aptCacheLine))

	orig = "/etc/schroot/sbuild"
	dir = "/etc/schroot/piuparts"
	sec = show s ++ "-piuparts"
	f = schrootPiupartsConf s
	munge = replace "-sbuild]" "-piuparts]"

-- | Bind-mount @/var/cache/apt/archives@ in all sbuild chroots so that the host
-- system and the chroot share the apt cache
--
-- This speeds up builds by avoiding unnecessary downloads of build
-- dependencies.
shareAptCache :: Property DebianLike
shareAptCache = File.containsLine "/etc/schroot/sbuild/fstab" aptCacheLine
	`requires` installed
	`describe` "sbuild schroots share host apt cache"

aptCacheLine :: String
aptCacheLine = "/var/cache/apt/archives /var/cache/apt/archives none rw,bind 0 0"

-- | Ensure that sbuild is installed
installed :: Property DebianLike
installed = Apt.installed ["sbuild"]

-- | Add an user to the sbuild group in order to use sbuild
usableBy :: User -> Property DebianLike
usableBy u = User.hasGroup u (Group "sbuild") `requires` installed

-- | Generate the apt keys needed by sbuild
keypairGenerated :: Property DebianLike
keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go
	`requires` installed
  where
	go :: Property DebianLike
	go = tightenTargets $
		cmdProperty "sbuild-update" ["--keygen"]
		`assume` MadeChange
	secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"

-- another script from wiki.d.o/sbuild
ccachePrepared :: Property DebianLike
ccachePrepared = propertyList "sbuild group ccache configured" $ props
	-- We only set a limit on the cache if it doesn't already exist, so the
	-- user can override our default limit
	& check (not <$> doesDirectoryExist "/var/cache/ccache-sbuild")
		(Ccache.hasLimits "/var/cache/ccache-sbuild" (Ccache.MaxSize "2G"))
	`before` Ccache.hasCache (Group "sbuild") Ccache.NoLimit
	& "/etc/schroot/sbuild/fstab" `File.containsLine`
	"/var/cache/ccache-sbuild /var/cache/ccache-sbuild none rw,bind 0 0"
		`describe` "ccache mounted in sbuild schroots"
	& "/var/cache/ccache-sbuild/sbuild-setup" `File.hasContent`
		[ "#!/bin/sh"
		, ""
		, "export CCACHE_DIR=/var/cache/ccache-sbuild"
		, "export CCACHE_UMASK=002"
		, "export CCACHE_COMPRESS=1"
		, "unset CCACHE_HARDLINK"
		, "export PATH=\"/usr/lib/ccache:$PATH\""
		, ""
		, "exec \"$@\""
		]
	& File.mode "/var/cache/ccache-sbuild/sbuild-setup"
		(combineModes (readModes ++ executeModes))

-- This doesn't seem to work with the current version of sbuild
-- -- | Block network access during builds
-- --
-- -- This is a hack from <https://wiki.debian.org/sbuild> until #802850 and
-- -- #802849 are resolved.
-- blockNetwork :: Property Linux
-- blockNetwork = Firewall.rule Firewall.OUTPUT Firewall.Filter Firewall.DROP
-- 	(Firewall.GroupOwner (Group "sbuild")
-- 	<> Firewall.NotDestination
-- 		[Firewall.IPWithNumMask (IPv4 "127.0.0.1") 8])
-- 	`requires` installed 	-- sbuild group must exist

-- ==== utility functions ====

schrootFromSystem :: System -> Maybe SbuildSchroot
schrootFromSystem system@(System _ arch) =
	extractSuite system
	>>= \suite -> return $ SbuildSchroot suite arch

stdMirror :: System -> Maybe Apt.Url
stdMirror (System (Debian _) _) = Just "http://httpredir.debian.org/debian"
stdMirror (System (Buntish _) _) = Just "mirror://mirrors.ubuntu.com/"
stdMirror _ = Nothing

schrootRoot :: SbuildSchroot -> FilePath
schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ a

schrootConf :: SbuildSchroot -> FilePath
schrootConf (SbuildSchroot s a) =
	"/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-sbuild-propellor"

schrootPiupartsConf :: SbuildSchroot -> FilePath
schrootPiupartsConf (SbuildSchroot s a) =
	"/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-piuparts-propellor"