module Propellor.Property.Sbuild (
SbuildSchroot(..),
builtFor,
built,
updated,
updatedFor,
piupartsConfFor,
piupartsConf,
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.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 ++ "-" ++ 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)
<!> 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)
aliasesLine :: Property UnixLike
aliasesLine = if suite == "unstable"
then File.containsLine (schrootConf s)
"aliases=UNRELEASED,sid,rc-buggy,experimental"
else doNothing
commandPrefix = File.containsLine (schrootConf s)
"command-prefix=/var/cache/ccache-sbuild/sbuild-setup,eatmydata"
ispartial = ifM (doesDirectoryExist (schrootRoot s </> "debootstrap"))
( do
removeChroot $ schrootRoot s
return True
, return False
)
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 ++ "-" ++ 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 ++ "-" ++ 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
where
go :: Property DebianLike
go = tightenTargets $
cmdProperty "sbuild-update" ["--keygen"]
`assume` MadeChange
secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec"
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 ++ "-" ++ 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"