module Propellor.Property.Sbuild (
SbuildSchroot(..),
built,
updated,
piupartsConf,
builtFor,
updatedFor,
piupartsConfFor,
installed,
keypairGenerated,
keypairInsecurelyGenerated,
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.Schroot as Schroot
import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.User as User
import Utility.FileMode
import Data.List
import Data.List.Utils
type Suite = String
data SbuildSchroot = SbuildSchroot Suite Architecture
instance Show SbuildSchroot where
show (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
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
built :: SbuildSchroot -> Apt.Url -> RevertableProperty DebianLike UnixLike
built s@(SbuildSchroot suite arch) mirror =
(go
`requires` keypairGenerated
`requires` ccachePrepared
`requires` installed
`requires` overlaysKernel)
<!> 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=" ++ architectureToDebianArchString 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)
aliasesLine :: Property UnixLike
aliasesLine = property' "maybe set aliases line" $ \w -> do
maybeOS <- getOS
case maybeOS of
Nothing -> return NoChange
Just (System _ hostArch) ->
if suite == "unstable" && hostArch == arch
then ensureProperty w $
schrootConf s `File.containsLine` aliases
else return NoChange
commandPrefix = File.containsLine (schrootConf s)
"command-prefix=/var/cache/ccache-sbuild/sbuild-setup,eatmydata"
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
ispartial = ifM (doesDirectoryExist (schrootRoot s </> "debootstrap"))
( do
removeChroot $ schrootRoot s
return True
, return False
)
aliases = "aliases=UNRELEASED,sid,rc-buggy,experimental"
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)
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 ++ "-" ++ architectureToDebianArchString arch]
`assume` MadeChange
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 ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-"
munge = replace "-propellor]" "-sbuild]"
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)
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]"
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"
installed :: Property DebianLike
installed = Apt.installed ["sbuild"]
usableBy :: User -> Property DebianLike
usableBy u = User.hasGroup u (Group "sbuild") `requires` installed
keypairGenerated :: Property DebianLike
keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go
`requires` installed
`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"]
& cmdProperty "rngd" ["-r", "/dev/urandom"] `assume` MadeChange
& keypairGenerated
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))
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 ++ "-" ++ 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"