summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Sbuild.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Sbuild.hs')
-rw-r--r--src/Propellor/Property/Sbuild.hs383
1 files changed, 383 insertions, 0 deletions
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
new file mode 100644
index 00000000..2647e69e
--- /dev/null
+++ b/src/Propellor/Property/Sbuild.hs
@@ -0,0 +1,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"