module Propellor.Property.Sbuild (
SbuildSchroot(..),
UseCcache(..),
built,
updated,
builtFor,
updatedFor,
installed,
keypairGenerated,
keypairInsecurelyGenerated,
usableBy,
) where
import Propellor.Base
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.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 Utility.Split
import Data.List
type Suite = String
data SbuildSchroot = SbuildSchroot Suite Architecture
instance ConfigurableValue SbuildSchroot where
val (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
data UseCcache = UseCcache | NoCcache
builtFor :: System -> UseCcache -> RevertableProperty DebianLike UnixLike
builtFor sys cc = go <!> deleted
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
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
where
go :: Property DebianLike
go = check (unpopulated (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
)
deleted = check (not <$> unpopulated (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
& proxyCacher
& ConfFile.containsIniSetting (schrootConf s)
( val s ++ "-sbuild"
, "command-prefix"
, intercalate "," commandPrefix
)
proxyCacher :: Property DebianLike
proxyCacher = property' "set schroot apt proxy" $ \w -> do
proxyInfo <- getProxyInfo
ensureProperty w $ case proxyInfo of
Just (Apt.HostAptProxy u) -> setChrootProxy u
Nothing -> (Apt.serviceInstalledRunning "apt-cacher-ng"
`before` setChrootProxy "http://localhost:3142")
where
getProxyInfo :: Propellor (Maybe Apt.HostAptProxy)
getProxyInfo = fromInfoVal <$> askInfo
setChrootProxy :: Apt.Url -> Property DebianLike
setChrootProxy u = tightenTargets $ File.hasContent
(schrootRoot s </> "etc/apt/apt.conf.d/20proxy")
[ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ]
aliasesLine :: Property UnixLike
aliasesLine = property' "maybe set aliases line" $ \w ->
sidHostArchSchroot s >>= \isSidHostArchSchroot ->
if isSidHostArchSchroot
then ensureProperty w $
ConfFile.containsIniSetting
(schrootConf s)
( val s ++ "-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 s)
noChange
where
fstab = "/etc/schroot/sbuild/fstab"
profile = "/etc/schroot/piuparts"
ispartial = ifM (doesDirectoryExist (schrootRoot s </> "debootstrap"))
( do
removeChroot $ schrootRoot s
return True
, return False
)
aliases = intercalate ","
[ "sid"
, "rc-buggy"
, "experimental"
, "UNRELEASED"
, "UNRELEASED-"
++ architectureToDebianArchString arch
++ "-sbuild"
]
commandPrefix = case cc of
UseCcache -> "/var/cache/ccache-sbuild/sbuild-setup":base
_ -> base
where
base = ["eatmydata"]
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 " ++ val s)
`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 " ++ 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]"
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"]
& 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))
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"
sidHostArchSchroot :: SbuildSchroot -> Propellor Bool
sidHostArchSchroot (SbuildSchroot suite arch) = do
maybeOS <- getOS
return $ case maybeOS of
Nothing -> False
Just (System _ hostArch) ->
suite == "unstable" && hostArch == arch