summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Propellor/Property/File.hs22
-rw-r--r--src/Propellor/Property/Sbuild.hs329
2 files changed, 137 insertions, 214 deletions
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 3293599a..340a6d02 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -126,18 +126,30 @@ newtype LinkTarget = LinkTarget FilePath
-- | Creates or atomically updates a symbolic link.
--
+-- Revert to ensure the symlink is not present.
+--
-- Does not overwrite regular files or directories.
-isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike
-link `isSymlinkedTo` (LinkTarget target) = property desc $
- go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link)
+isSymlinkedTo :: FilePath -> LinkTarget -> RevertableProperty UnixLike UnixLike
+link `isSymlinkedTo` (LinkTarget target) = linked <!> notLinked
where
- desc = link ++ " is symlinked to " ++ target
+ linked = property (link ++ " is symlinked to " ++ target) $
+ go =<< getLinkStatus
+
go (Right stat) =
if isSymbolicLink stat
then checkLink
else nonSymlinkExists
go (Left _) = makeChange $ createSymbolicLink target link
+ notLinked = property (link ++ "does not exist as a symlink") $
+ stop =<< getLinkStatus
+
+ stop (Right stat) =
+ if isSymbolicLink stat
+ then makeChange $ nukeFile link
+ else nonSymlinkExists
+ stop (Left _) = noChange
+
nonSymlinkExists = do
warningMessage $ link ++ " exists and is not a symlink"
return FailedChange
@@ -148,6 +160,8 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $
else makeChange updateLink
updateLink = createSymbolicLink target `viaStableTmp` link
+ getLinkStatus = liftIO $ tryIO $ getSymbolicLinkStatus link
+
-- | Ensures that a file is a copy of another (regular) file.
isCopyOf :: FilePath -> FilePath -> Property UnixLike
f `isCopyOf` src = property desc $ go =<< (liftIO $ tryIO $ getFileStatus src)
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index 210fb20b..29931722 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -6,23 +6,24 @@ 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:
+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
+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)
+newer
-The latter is due to the migration from GnuPG v1 to GnuPG v2.1 in
-Debian stretch, which older sbuild can't handle.
+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
+-- TODO can we use '$' here or do we require more brackets?
+> & Sbuild.built Sbuild.UseCcache $ props
+> & osDebian Unstable X86_32
+> & Sbuild.update `period` Weekly 1
> & Sbuild.usableBy (User "spwhitton")
> & Schroot.overlaysInTmpfs
@@ -30,7 +31,8 @@ If you are using sbuild older than 0.70.0, you also need:
> & Sbuild.keypairGenerated
-In @~/.sbuildrc@ (sbuild 0.71.0 or newer):
+To take advantage of the piuparts and autopkgtest support, add to your
+@~/.sbuildrc@ (assumes sbuild 0.71.0 or newer):
> $piuparts_opts = [
> '--no-eatmydata',
@@ -41,40 +43,15 @@ In @~/.sbuildrc@ (sbuild 0.71.0 or newer):
>
> $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,
+ update,
-- * Global sbuild configuration
-- blockNetwork,
- installed,
keypairGenerated,
keypairInsecurelyGenerated,
usableBy,
@@ -82,12 +59,15 @@ module Propellor.Property.Sbuild (
) where
import Propellor.Base
+import Propellor.Types.Core
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.Chroot as Chroot
import qualified Propellor.Property.ConfFile as ConfFile
+import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.File as File
-- import qualified Propellor.Property.Firewall as Firewall
import qualified Propellor.Property.Schroot as Schroot
@@ -98,92 +78,81 @@ 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
+-- | Build and configure a schroot for use with sbuild
--
--- 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
+-- The second parameter should specify, at a minimum, the operating system for
+-- the schroot. This is usually done using a property like 'osDebian'
+built
+ :: UseCcache
+ -> Props metatypes
+ -> RevertableProperty (HasInfo + DebianLike) Linux
+built cc ps = case schrootSystem ps of
+ Nothing -> errorMessage
+ "sbuild schroot does not specify suite and/or architecture"
+ Just s@(System _ arch) -> case Debootstrap.extractSuite s of
+ Nothing -> errorMessage
+ "sbuild schroot does not specify suite"
+ Just suite -> built' cc ps suite
+ (architectureToDebianArchString arch)
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
+ schrootSystem :: Props metatypes -> Maybe System
+ schrootSystem (Props ps) = fromInfoVal . fromInfo $
+ mconcat (map getInfo ps)
+
+built'
+ :: UseCcache
+ -> Props metatypes
+ -> String
+ -> String
+ -> RevertableProperty (HasInfo + DebianLike) Linux
+built' cc ps suite arch = provisioned <!> deleted
where
- go :: Property DebianLike
- go = check (isUnpopulated (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
- )
+ provisioned :: Property (HasInfo + DebianLike)
+ provisioned = combineProperties desc $ props
+ & cleanupOldConfig
+ & overlaysKernel
+ & preReqsInstalled
+ & ccacheMaybePrepared cc
+ & Chroot.provisioned schroot
+ & proxyCacher
+ & conf suite arch
+ where
+ desc = "built sbuild schroot for " ++ suiteArch
+
-- TODO we should kill any sessions still using the chroot
-- before destroying it (as suggested by sbuild-destroychroot)
- deleted = check (not <$> isUnpopulated (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
- )
+ deleted :: Property Linux
+ deleted = propertyList desc $ props
+ ! Chroot.provisioned schroot
+ ! compatSymlink
+ & File.notPresent schrootConf
+ where
+ desc = "no sbuild schroot for " ++ suiteArch
+
+ conf suite arch = map pair
+ [ ("description", (suite ++ "/" ++ arch ++ " autobuilder"))
+ , ("groups", "root,sbuild")
+ , ("root-groups", "root,sbuild")
+ , ("profile", "sbuild")
+ , ("type", "directory")
+ , ("directory", schrootRoot)
+ -- TODO conditionalise (fold into overlayKernels prop?)
+ , ("union-type", "overlay")
+ , ("command-prefix", (intercalate "," commandPrefix))
+ ]
+ where
+ pair (k, v) = ConfFile.containsIniSetting schrootConf
+ (suiteArch ++ "-sbuild", k, v)
+
+ compatSymlink = File.isSymlinkedTo
+ ("/etc/sbuild/chroot" </> suiteArch ++ "-sbuild")
+ (File.LinkTarget schrootRoot)
-- 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
@@ -207,7 +176,7 @@ built s@(SbuildSchroot suite arch) mirror cc =
getProxyInfo = fromInfoVal <$> askInfo
setChrootProxy :: Apt.Url -> Property DebianLike
setChrootProxy u = tightenTargets $ File.hasContent
- (schrootRoot s </> "etc/apt/apt.conf.d/20proxy")
+ (schrootRoot </> "etc/apt/apt.conf.d/20proxy")
[ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ]
-- if we're building a sid chroot, add useful aliases
@@ -215,24 +184,20 @@ built s@(SbuildSchroot suite arch) mirror cc =
-- 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 ->
+ sidHostArchSchroot suite arch >>= \isSidHostArchSchroot ->
if isSidHostArchSchroot
then ensureProperty w $
- ConfFile.containsIniSetting
- (schrootConf s)
- ( val s ++ "-sbuild"
+ ConfFile.containsIniSetting schrootConf
+ ( suiteArch ++ "-sbuild"
, "aliases"
, aliases
)
else return NoChange
- -- If the user has indicated that this host should use
+ -- 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.)
+ -- to a kernel supporting OverlayFS. Otherwise, executing sbuild(1)
+ -- will fail.
overlaysKernel :: Property DebianLike
overlaysKernel = property' "reboot for union-type=overlay" $ \w ->
Schroot.usesOverlays >>= \usesOverlays ->
@@ -249,22 +214,28 @@ built s@(SbuildSchroot suite arch) mirror cc =
check (doesFileExist fstab)
(File.lacksLine fstab aptCacheLine)
void $ liftIO . tryIO $ removeDirectoryRecursive profile
- void $ liftIO $ nukeFile (schrootPiupartsConf s)
+ void $ liftIO $ nukeFile schrootPiupartsConf
-- 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
- )
-
+ schrootPiupartsConf = "/etc/schroot/chroot.d"
+ </> suiteArch ++ "-piuparts-propellor"
+
+ -- the schroot itself
+ schroot = Chroot.debootstrapped Debootstrap.BuilddD
+ schrootRoot schrootProps
+ -- TODO need to prepend 'ps' to this list of props
+ schrootProps = props
+ & Apt.stdSourcesList
+ & Apt.installed ["eatmydata", "ccache"]
+
+ -- static values
+ suiteArch = suite ++ "-" ++ arch
+ schrootRoot = "/srv/chroot" </> suiteArch
+ schrootConf = "/etc/schroot/chroot.d"
+ </> suiteArch ++ "-sbuild-propellor"
aliases = intercalate ","
[ "sid"
-- if the user wants to build for experimental, they would use
@@ -277,10 +248,9 @@ built s@(SbuildSchroot suite arch) mirror cc =
, "UNRELEASED"
-- the following is for dgit compatibility:
, "UNRELEASED-"
- ++ architectureToDebianArchString arch
+ ++ arch
++ "-sbuild"
]
-
commandPrefix = case cc of
UseCcache -> "/var/cache/ccache-sbuild/sbuild-setup":base
_ -> base
@@ -289,72 +259,27 @@ built s@(SbuildSchroot suite arch) mirror cc =
-- | 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]"
-
+-- This replaces use of sbuild-update(1).
+update :: Property DebianLike
+update = Apt.update `before` Apt.upgrade `before` Apt.autoRemove
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"]
+-- | Ensure that sbuild and associated utilities are installed
+preReqsInstalled :: Property DebianLike
+preReqsInstalled = Apt.installed ["piuparts", "autopkgtest", "lintian", "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
+usableBy u = User.hasGroup u (Group "sbuild") `requires` preReqsInstalled
-- | 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
+ `requires` preReqsInstalled
-- 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"
@@ -454,12 +379,12 @@ ccachePrepared = propertyList "sbuild group ccache configured" $ props
userConfig :: User -> Property DebianLike
userConfig user@(User u) = go
`requires` usableBy user
- `requires` Apt.installed ["piuparts", "autopkgtest", "lintian"]
+ `requires` preReqsInstalled
where
go :: Property DebianLike
go = property' ("~/.sbuildrc for " ++ u) $ \w -> do
- h <- liftIO (User.homedir user)
- ensureProperty w $ File.hasContent (h </> ".sbuildrc")
+ h <- liftIO (User.homedir user)
+ ensureProperty w $ File.hasContent (h </> ".sbuildrc")
[ "$run_lintian = 1;"
, ""
, "$run_piuparts = 1;"
@@ -477,22 +402,6 @@ userConfig user@(User u) = go
-- ==== 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
@@ -501,8 +410,8 @@ schrootPiupartsConf (SbuildSchroot s a) =
-- 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
+sidHostArchSchroot :: String -> String -> Propellor Bool
+sidHostArchSchroot suite arch = do
maybeOS <- getOS
return $ case maybeOS of
Nothing -> False