summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Sbuild.hs
blob: 23f3b3111316236b506ad5ef6bffab411240dcf5 (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
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE TypeFamilies #-}

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

Build and maintain schroots for use with sbuild.

For convenience we set up several enhancements, such as ccache and
eatmydata.  This means we have to make several assumptions:

1. you want to build for a Debian release strictly newer than squeeze,
or for a Buntish release newer than or equal to trusty

2. if you want to build for Debian stretch or newer, you have sbuild 0.70.0 or
newer (there is a backport to jessie)

The latter is due to the migration from GnuPG v1 to GnuPG v2.1 in
Debian stretch, which older sbuild can't handle.

Suggested usage in @config.hs@:

>  & Apt.installed ["piuparts", "autopkgtest", "lintian"]
>  & Sbuild.builtFor (System (Debian Linux Unstable) X86_32) Sbuild.UseCcache
>  & Sbuild.updatedFor (System (Debian Linux Unstable) X86_32) `period` Weekly 1
>  & Sbuild.usableBy (User "spwhitton")
>  & Schroot.overlaysInTmpfs

If you are using sbuild older than 0.70.0, you also need:

>  & Sbuild.keypairGenerated

In @~/.sbuildrc@ (sbuild 0.71.0 or newer):

>  $piuparts_opts = [
>      '--no-eatmydata',
>      '--schroot',
>      '%r-%a-sbuild',
>      '--fail-if-inadequate',
>      ];
>
>  $autopkgtest_root_args = "";
>  $autopkgtest_opts = ["--", "schroot", "%r-%a-sbuild"];

We use @sbuild-createchroot(1)@ to create a chroot to the
specification of @sbuild-setup(7)@.  This avoids running propellor
inside the chroot to set it up.  While that approach is flexible, a
propellor spin pulls in a lot of dependencies.  This could defeat
using sbuild to determine if you've included all necessary build
dependencies in your source package control file.

Nevertheless, the chroot that @sbuild-createchroot(1)@ creates might not meet
your needs.  For example, you might need to enable apt's https support.  In that
case you can do something like this in @config.hs@:

>  & Sbuild.built (System (Debian Linux Unstable) X86_32) `before` mySetup
>    where
>  	mySetup = Chroot.provisioned myChroot
>  	myChroot = Chroot.debootstrapped
>  		 	Debootstrap.BuilddD "/srv/chroot/unstable-i386"
>  		-- the extra configuration you need:
>  		& Apt.installed ["apt-transport-https"]
-}

-- Also see the --setup-only option of sbuild-createchroot

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

import Propellor.Base
import Propellor.Types.Info
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.Schroot as Schroot
import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.User as User
import Utility.FileMode
import Utility.Split

import Data.List

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 ConfigurableValue SbuildSchroot where
	val (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch

-- | Whether an sbuild schroot should use ccache during builds
--
-- ccache is generally useful but it breaks building some packages.  This data
-- types allows you to toggle it on and off for particular schroots.
data UseCcache = UseCcache | NoCcache

-- | Build and configure a schroot for use with sbuild using a distribution's
-- standard mirror
--
-- This function is a convenience wrapper around 'built', allowing the user to
-- identify the schroot and distribution using the 'System' type
builtFor :: System -> UseCcache -> RevertableProperty DebianLike UnixLike
builtFor sys cc = go <!> deleted
  where
	go = Apt.withMirror goDesc $ \u -> property' goDesc $ \w ->
		case schrootFromSystem sys of
			Just s  -> ensureProperty w $
				setupRevertableProperty $ built s u cc
			_ -> 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" cc
			Nothing -> noChange
	goDesc = "sbuild schroot for " ++ show sys

-- | Build and configure a schroot for use with sbuild
built :: SbuildSchroot -> Apt.Url -> UseCcache -> RevertableProperty DebianLike UnixLike
built s@(SbuildSchroot suite arch) mirror cc =
	((go `before` enhancedConf)
	`requires` ccacheMaybePrepared cc
	`requires` installed
	`requires` overlaysKernel
	`requires` cleanupOldConfig)
	<!> deleted
  where
	go :: Property DebianLike
	go = check (unpopulated (schrootRoot s) <||> ispartial) $
		property' ("built sbuild schroot for " ++ val s) make
	make w = do
		de <- liftIO standardPathEnv
		let params = Param <$>
			[ "--arch=" ++ architectureToDebianArchString arch
			, "--chroot-suffix=-propellor"
			, "--include=eatmydata,ccache"
			, suite
			, schrootRoot s
			, mirror
			]
		ifM (liftIO $
			boolSystemEnv "sbuild-createchroot" params (Just de))
			( ensureProperty w $ fixConfFile s
			, return FailedChange
			)
	-- TODO we should kill any sessions still using the chroot
	-- before destroying it (as suggested by sbuild-destroychroot)
	deleted = check (not <$> unpopulated (schrootRoot s)) $
		property ("no sbuild schroot for " ++ val s) $ do
			liftIO $ removeChroot $ schrootRoot s
			liftIO $ nukeFile
				("/etc/sbuild/chroot" </> val s ++ "-sbuild")
			makeChange $ nukeFile (schrootConf s)

	enhancedConf =
		combineProperties ("enhanced schroot conf for " ++ val s) $ props
			& aliasesLine
			-- set up an apt proxy/cacher
			& proxyCacher
			-- enable ccache and eatmydata for speed
			& ConfFile.containsIniSetting (schrootConf s)
				( val s ++ "-sbuild"
				, "command-prefix"
				, intercalate "," commandPrefix
				)

	-- set the apt proxy inside the chroot.  If the host has an apt proxy
	-- set, assume that it does some sort of caching.  Otherwise, set up a
	-- local apt-cacher-ng instance
	--
	-- (if we didn't assume that the apt proxy does some sort of caching,
	-- we'd need to complicate the Apt.HostAptProxy type to indicate whether
	-- the proxy caches, and if it doesn't, set up apt-cacher-ng as an
	-- intermediary proxy between the chroot's apt and the Apt.HostAptProxy
	-- proxy.  This complexity is more likely to cause problems than help
	-- anyone)
	proxyCacher :: Property DebianLike
	proxyCacher = property' "set schroot apt proxy" $ \w -> do
		proxyInfo <- getProxyInfo
		ensureProperty w $ case proxyInfo of
			Just (Apt.HostAptProxy u) -> setChrootProxy u
			Nothing -> (Apt.serviceInstalledRunning "apt-cacher-ng"
				`before` setChrootProxy "http://localhost:3142")
	  where
		getProxyInfo :: Propellor (Maybe Apt.HostAptProxy)
		getProxyInfo = fromInfoVal <$> askInfo
		setChrootProxy :: Apt.Url -> Property DebianLike
		setChrootProxy u = tightenTargets $ File.hasContent
			(schrootRoot s </> "etc/apt/apt.conf.d/20proxy")
			[ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ]

	-- if we're building a sid chroot, add useful aliases
	-- In order to avoid more than one schroot getting the same aliases, we
	-- only do this if the arch of the chroot equals the host arch.
	aliasesLine :: Property UnixLike
	aliasesLine = property' "maybe set aliases line" $ \w ->
		sidHostArchSchroot s >>= \isSidHostArchSchroot ->
			if isSidHostArchSchroot
			then ensureProperty w $
				ConfFile.containsIniSetting
					(schrootConf s)
					( val s ++ "-sbuild"
					, "aliases"
					, aliases
					)
			else return NoChange

	-- If the user has indicated that this host should use
	-- union-type=overlay schroots, we need to ensure that we have rebooted
	-- to a kernel supporting OverlayFS before we execute
	-- sbuild-setupchroot(1).  Otherwise, sbuild-setupchroot(1) will fail to
	-- add the union-type=overlay line to the schroot config.
	-- (We could just add that line ourselves, but then sbuild wouldn't work
	-- for the user, so we might as well do the reboot for them.)
	overlaysKernel :: Property DebianLike
	overlaysKernel = property' "reboot for union-type=overlay" $ \w ->
		Schroot.usesOverlays >>= \usesOverlays ->
			if usesOverlays
			then ensureProperty w $
				Reboot.toKernelNewerThan "3.18"
			else noChange

	-- clean up config from earlier versions of this module
	cleanupOldConfig :: Property UnixLike
	cleanupOldConfig =
		property' "old sbuild module config cleaned up" $ \w -> do
			void $ ensureProperty w $
				check (doesFileExist fstab)
				(File.lacksLine fstab aptCacheLine)
			void $ liftIO . tryIO $ removeDirectoryRecursive profile
			void $ liftIO $ nukeFile (schrootPiupartsConf s)
			-- assume this did nothing
			noChange
	  where
		fstab = "/etc/schroot/sbuild/fstab"
		profile = "/etc/schroot/piuparts"

	-- 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
		)

	aliases = intercalate ","
		[ "sid"
		-- if the user wants to build for experimental, they would use
		-- their sid chroot and sbuild's --extra-repository option to
		-- enable experimental
		, "rc-buggy"
		, "experimental"
		-- we assume that building for UNRELEASED means building for
		-- unstable
		, "UNRELEASED"
		-- the following is for dgit compatibility:
		, "UNRELEASED-"
			++ architectureToDebianArchString arch
			++ "-sbuild"
		]

	commandPrefix = case cc of
		UseCcache -> "/var/cache/ccache-sbuild/sbuild-setup":base
		_ -> base
	  where
		base = ["eatmydata"]

-- | Ensure that an sbuild schroot's packages and apt indexes are updated
--
-- This function is a convenience wrapper around '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 " ++ val s)
	`requires` installed
  where
	go :: Property DebianLike
	go = tightenTargets $ cmdProperty
		"sbuild-update" ["-udr", suite ++ "-" ++ architectureToDebianArchString 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 " ++ val 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" </> val s ++ "-propellor")
			("/etc/sbuild/chroot" </> val s ++ "-sbuild")
		ensureProperty w $
			File.fileProperty "replace dummy suffix" (map munge) new
  where
	new = schrootConf s
	dir = takeDirectory new
	tempPrefix = dir </> suite ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-"
	munge = replace "-propellor]" "-sbuild]"


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
--
-- You only need this if you are using sbuild older than 0.70.0.
keypairGenerated :: Property DebianLike
keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go
	`requires` installed
	-- Work around Debian bug #792100 which is present in Jessie.
	-- Since this is a harmless mkdir, don't actually check the OS
	`requires` File.dirExists "/root/.gnupg"
  where
	go :: Property DebianLike
	go = tightenTargets $
		cmdProperty "sbuild-update" ["--keygen"]
		`assume` MadeChange

secKeyFile :: FilePath
secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"

-- | Generate the apt keys needed by sbuild using a low-quality source of
-- randomness
--
-- Note that any running rngd will be killed; if you are using rngd, you should
-- arrange for it to be restarted after this property has been ensured.  E.g.
--
-- >  & Sbuild.keypairInsecurelyGenerated
-- >  	`onChange` Systemd.started "my-rngd-service"
--
-- Useful on throwaway build VMs.
--
-- You only need this if you are using sbuild older than 0.70.0.
keypairInsecurelyGenerated :: Property DebianLike
keypairInsecurelyGenerated = check (not <$> doesFileExist secKeyFile) go
  where
	go :: Property DebianLike
	go = combineProperties "sbuild keyring insecurely generated" $ props
		& Apt.installed ["rng-tools"]
		-- If this dir does not exist the sbuild key generation command
		-- will fail; the user might have deleted it to work around
		-- #831462
		& File.dirExists "/var/lib/sbuild/apt-keys"
		-- If there is already an rngd process running we have to kill
		-- it, as it might not be feeding to /dev/urandom.  We can't
		-- kill by pid file because that is not guaranteed to be the
		-- default (/var/run/rngd.pid), so we killall
		& userScriptProperty (User "root")
			[ "start-stop-daemon -q -K -R 10 -o -n rngd"
			, "rngd -r /dev/urandom"
			]
			`assume` MadeChange
		& keypairGenerated
		-- Kill off the rngd process we spawned
		& userScriptProperty (User "root")
			["kill $(cat /var/run/rngd.pid)"]
			`assume` MadeChange

ccacheMaybePrepared :: UseCcache -> Property DebianLike
ccacheMaybePrepared cc = case cc of
	UseCcache -> ccachePrepared
	NoCcache  -> doNothing

-- 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

-- | Maintain recommended ~/.sbuildrc for a user, and adds them to the
-- sbuild group
--
-- You probably want a custom ~/.sbuildrc on your workstation, but
-- this property is handy for quickly setting up build boxes.
userConfig :: User -> Property DebianLike
userConfig user@(User u) = go
	`requires` usableBy user
	`requires` Apt.installed ["piuparts", "autopkgtest", "lintian"]
  where
	go :: Property DebianLike
	go = property' ("~/.sbuildrc for " ++ u) $ \w -> do
    		h <- liftIO (User.homedir user)
    		ensureProperty w $ File.hasContent (h </> ".sbuildrc")
			[ "$run_lintian = 1;"
			, ""
			, "$run_piuparts = 1;"
			, "$piuparts_opts = ["
			, "    '--no-eatmydata',"
			, "    '--schroot',"
			, "    '%r-%a-sbuild',"
			, "    '--fail-if-inadequate',"
			, "    ];"
			, ""
			, "$run_autopkgtest = 1;"
			, "$autopkgtest_root_args = \"\";"
			, "$autopkgtest_opts = [\"--\", \"schroot\", \"%r-%a-sbuild\"];"
			]

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

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

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

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

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

-- Determine whether a schroot is
--
-- (i)  Debian sid, and
-- (ii) the same architecture as the host.
--
-- This is the "sid host arch schroot".  It is considered the default schroot
-- for sbuild builds, so we add useful aliases that work well with the suggested
-- ~/.sbuildrc given in the haddock
sidHostArchSchroot :: SbuildSchroot -> Propellor Bool
sidHostArchSchroot (SbuildSchroot suite arch) = do
	maybeOS <- getOS
	return $ case maybeOS of
		Nothing -> False
		Just (System _ hostArch) ->
			suite == "unstable" && hostArch == arch