{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE TypeFamilies #-}
module Propellor.Property.Sbuild (
UseCcache(..),
built,
update,
useHostProxy,
osDebianStandard,
keypairGenerated,
keypairInsecurelyGenerated,
usableBy,
userConfig,
) where
import Propellor.Base
import Propellor.Types.Core
import Propellor.Types.Info
import Propellor.Property.Debootstrap (extractSuite)
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.Schroot as Schroot
import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.Localdir as Localdir
import qualified Propellor.Property.User as User
import Data.List
data UseCcache = UseCcache | NoCcache
built
:: UseCcache
-> Props metatypes
-> RevertableProperty (HasInfo + DebianLike) Linux
built cc ps = case schrootSystem ps of
Nothing -> emitError
Just s@(System _ arch) -> case extractSuite s of
Nothing -> emitError
Just suite -> built' cc ps suite
(architectureToDebianArchString arch)
where
schrootSystem :: Props metatypes -> Maybe System
schrootSystem (Props ps') = fromInfoVal . fromInfo $
mconcat (map getInfo ps')
emitError :: RevertableProperty (HasInfo + DebianLike) Linux
emitError = impossible theError <!> impossible theError
theError = "sbuild schroot does not specify suite and/or architecture"
built'
:: UseCcache
-> Props metatypes
-> String
-> String
-> RevertableProperty (HasInfo + DebianLike) Linux
built' cc (Props ps) suite arch = provisioned <!> deleted
where
provisioned :: Property (HasInfo + DebianLike)
provisioned = combineProperties desc $ props
& cleanupOldConfig
& overlaysKernel
& preReqsInstalled
& ccacheMaybePrepared cc
& Chroot.provisioned schroot
& conf suite arch
where
desc = "built sbuild schroot for " ++ suiteArch
deleted :: Property Linux
deleted = combineProperties desc $ props
! Chroot.provisioned schroot
! compatSymlink
& File.notPresent schrootConf
where
desc = "no sbuild schroot for " ++ suiteArch
conf suite' arch' = combineProperties "sbuild config file" $ props
& pair "description" (suite' ++ "/" ++ arch' ++ " autobuilder")
& pair "groups" "root,sbuild"
& pair "root-groups" "root,sbuild"
& pair "profile" "sbuild"
& pair "type" "directory"
& pair "directory" schrootRoot
& unionTypeOverlay
& aliasesLine
& pair "command-prefix" (intercalate "," commandPrefix)
where
pair k v = ConfFile.containsIniSetting schrootConf
(suiteArch ++ "-sbuild", k, v)
unionTypeOverlay :: Property DebianLike
unionTypeOverlay = property' "add union-type = overlay" $ \w ->
Schroot.usesOverlays >>= \usesOverlays ->
if usesOverlays
then ensureProperty w $
pair "union-type" "overlay"
else noChange
compatSymlink = File.isSymlinkedTo
("/etc/sbuild/chroot" </> suiteArch ++ "-sbuild")
(File.LinkTarget schrootRoot)
aliasesLine :: Property UnixLike
aliasesLine = property' "maybe set aliases line" $ \w ->
sidHostArchSchroot suite arch >>= \isSidHostArchSchroot ->
if isSidHostArchSchroot
then ensureProperty w $
ConfFile.containsIniSetting schrootConf
( suiteArch ++ "-sbuild"
, "aliases"
, aliases
)
else return NoChange
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
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
noChange
where
fstab = "/etc/schroot/sbuild/fstab"
profile = "/etc/schroot/piuparts"
schrootPiupartsConf = "/etc/schroot/chroot.d"
</> suiteArch ++ "-piuparts-propellor"
schroot = Chroot.debootstrapped Debootstrap.BuilddD
schrootRoot (Props schrootProps)
schrootProps =
ps ++ [toChildProperty $ Apt.installed ["eatmydata", "ccache"]
, toChildProperty $ Localdir.removed]
suiteArch = suite ++ "-" ++ arch
schrootRoot = "/srv/chroot" </> suiteArch
schrootConf = "/etc/schroot/chroot.d"
</> suiteArch ++ "-sbuild-propellor"
aliases = intercalate ","
[ "sid"
, "rc-buggy"
, "experimental"
, "UNRELEASED"
, "UNRELEASED-"
++ arch
++ "-sbuild"
]
commandPrefix = case cc of
UseCcache -> "/var/cache/ccache-sbuild/sbuild-setup":base
_ -> base
where
base = ["eatmydata"]
osDebianStandard :: Property Debian
osDebianStandard = propertyList "standard Debian sbuild properties" $ props
& Apt.stdSourcesList
update :: Property DebianLike
update = Apt.update `before` Apt.upgrade `before` Apt.autoRemove
useHostProxy :: Host -> Property DebianLike
useHostProxy h = property' "use host's apt proxy" $ \w ->
case getProxyInfo of
Just (Apt.HostAptProxy u) -> ensureProperty w (Apt.proxy' u)
Nothing -> noChange
where
getProxyInfo = fromInfoVal . fromInfo . hostInfo $ h
aptCacheLine :: String
aptCacheLine = "/var/cache/apt/archives /var/cache/apt/archives none rw,bind 0 0"
preReqsInstalled :: Property DebianLike
preReqsInstalled = Apt.installed ["piuparts", "autopkgtest", "lintian", "sbuild"]
usableBy :: User -> Property DebianLike
usableBy u = User.hasGroup u (Group "sbuild") `requires` preReqsInstalled
keypairGenerated :: Property DebianLike
keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go
`requires` preReqsInstalled
`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"
keypairInsecurelyGenerated :: Property DebianLike
keypairInsecurelyGenerated = check (not <$> doesFileExist secKeyFile) go
where
go :: Property DebianLike
go = combineProperties "sbuild keyring insecurely generated" $ props
& Apt.installed ["rng-tools"]
& File.dirExists "/var/lib/sbuild/apt-keys"
& userScriptProperty (User "root")
[ "start-stop-daemon -q -K -R 10 -o -n rngd"
, "rngd -r /dev/urandom"
]
`assume` MadeChange
& keypairGenerated
& userScriptProperty (User "root")
["kill $(cat /var/run/rngd.pid)"]
`assume` MadeChange
ccacheMaybePrepared :: UseCcache -> Property DebianLike
ccacheMaybePrepared cc = case cc of
UseCcache -> ccachePrepared
NoCcache -> doNothing
ccachePrepared :: Property DebianLike
ccachePrepared = propertyList "sbuild group ccache configured" $ props
& 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))
userConfig :: User -> Property DebianLike
userConfig user@(User u) = go
`requires` usableBy user
`requires` preReqsInstalled
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\"];"
]
sidHostArchSchroot :: String -> String -> Propellor Bool
sidHostArchSchroot suite arch = do
maybeOS <- getOS
return $ case maybeOS of
Nothing -> False
Just (System _ hostArch) ->
let hostArch' = architectureToDebianArchString hostArch
in suite == "unstable" && hostArch' == arch