propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

commit e057aa2dccc565fab5350a715ee3a69318d1a4db
parent 1a1dd6d50dfc22e04a5f6a3c13feccc181393c81
Author: rsiddharth <s@ricketyspace.net>
Date:   Tue, 28 Nov 2017 04:15:03 +0000

Merge remote-tracking branch 'upstream/master'

Diffstat:
debian/changelog | 50++++++++++++++++++++++++++++++++++++++++++++++++++
joeyconfig.hs | 63+++++++++++++++++++++++++++++++--------------------------------
propellor.cabal | 6+++++-
src/Propellor/Bootstrap.hs | 6++++--
src/Propellor/Engine.hs | 2+-
src/Propellor/Property.hs | 8++++++++
src/Propellor/Property/Apt.hs | 12++++++++----
src/Propellor/Property/Chroot.hs | 22----------------------
src/Propellor/Property/Debootstrap.hs | 37++++++++++++++++++++++++++++++++++---
src/Propellor/Property/DiskImage.hs | 111+++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------
src/Propellor/Property/DiskImage/PartSpec.hs | 189+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
src/Propellor/Property/Fail2Ban.hs | 40+++++++++++++++++++++++++++++++++++-----
src/Propellor/Property/File.hs | 24+++++++++++++++++++-----
src/Propellor/Property/Firejail.hs | 2+-
src/Propellor/Property/FlashKernel.hs | 63+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Machine.hs | 201+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Mount.hs | 20++++++++++++--------
src/Propellor/Property/Parted.hs | 23++++++++++++++++++++---
src/Propellor/Property/PropellorRepo.hs | 4+++-
src/Propellor/Property/Qemu.hs | 49+++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Sbuild.hs | 380++++++++++++++++++++++++++++++-------------------------------------------------
src/Propellor/Property/Service.hs | 34+++++++++++++++++++++++++++++++++-
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 7++-----
src/Propellor/Property/SiteSpecific/GitHome.hs | 9++++++++-
src/Propellor/Property/SiteSpecific/JoeySites.hs | 61+++++++++++++++++++++++++++++++++----------------------------
src/Propellor/Property/Uboot.hs | 36++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Bootloader.hs | 13+++++++++++--
src/Propellor/Types/PartSpec.hs | 60++++--------------------------------------------------------
28 files changed, 1064 insertions(+), 468 deletions(-)

diff --git a/debian/changelog b/debian/changelog @@ -1,3 +1,53 @@ +propellor (5.1.0-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Thu, 23 Nov 2017 14:49:17 -0700 + +propellor (5.1.0) unstable; urgency=medium + + [ Sean Whitton ] + * File.isSymlinkedTo now revertable. (minor API change) + * Sbuild module changes: + - Type of Sbuild.built changed to accept additional properties to be + ensured inside schroots. (API change) + See the suggested usage in module's documentation for new syntax. + - Drop Sbuild.installed, Sbuild.builtFor, Sbuild.updated, + Sbuild.updatedFor. (API change) + Use Sbuild.built instead. See suggested usage in module's documentation. + - Propellor no longer sets up apt proxies in sbuild chroots automatically. + Instead, pass the new Sbuild.useHostProxy to Sbuild.built to have + Propellor propagate the host's Apt proxy configuration into the chroot. + See suggested usage in module's documentation. + - Internally, Propellor no longer invokes sbuild-createchroot(1) to build + schroots. + - Update documentation. + + -- Joey Hess <id@joeyh.name> Thu, 23 Nov 2017 10:38:16 -0400 + +propellor (5.0.0) unstable; urgency=medium + + * Debootstrap.built now supports bootstrapping chroots for foreign + OS's, using qemu-user-static. + * Machine: New module collecting machine-specific properties for + building bootable images for ARM boards. + Tested working boards: Olimex Lime, CubieTruck, Banana Pi, SheevaPlug. + * Diskimage.imageBuiltFor: New property to build a disk image for a Host, + using partition table information configured via the new properties + hasPartitionTableType, hasPartition and adjustPartition. + * Chroot.noServices moved to Service.noServices and its type changed. + (API change) + * Service: Avoid starting services when noServices is used. + * Add Typeable instance to OriginUrl, fixing build with old versions + of ghc. + * Added Propellor.Property.impossible + * Fail2Ban: Added several additional properties. + Thanks, Félix Sipma. + * Fail2Ban: Renamed jail.d conf file to use .local. + Thanks, Félix Sipma. + + -- Joey Hess <id@joeyh.name> Sun, 19 Nov 2017 15:42:44 -0400 + propellor (4.9.0-1) unstable; urgency=medium * Package new upstream release. diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -6,6 +6,8 @@ import Propellor import Propellor.Property.Scheduled import Propellor.Property.DiskImage import Propellor.Property.Chroot +import Propellor.Property.Machine +import Propellor.Property.Bootstrap import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network @@ -23,6 +25,7 @@ import qualified Propellor.Property.Git as Git import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.LetsEncrypt as LetsEncrypt +import qualified Propellor.Property.Locale as Locale import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Borg as Borg import qualified Propellor.Property.Gpg as Gpg @@ -94,16 +97,9 @@ darkstar = host "darkstar.kitenet.net" $ props & Ssh.userKeys (User "joey") hostContext [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - & imageBuilt (VirtualBoxPointer "/srv/test.vmdk") mychroot MSDOS - [ partition EXT2 `mountedAt` "/boot" - , partition EXT4 `mountedAt` "/" - , swapPartition (MegaBytes 256) - ] - where - mychroot d = debootstrapped mempty d $ props - & osDebian Unstable X86_64 - & Apt.installed ["linux-image-amd64"] - & Grub.installed PC + & imageBuiltFor honeybee + (RawDiskImage "/srv/honeybee.img") + (Debootstrapped mempty) gnu :: Host gnu = host "gnu.kitenet.net" $ props @@ -184,22 +180,30 @@ honeybee :: Host honeybee = host "honeybee.kitenet.net" $ props & standardSystem Testing ARMHF [ "Home router and arm git-annex build box." ] - - -- Hard to get console access, so no automatic upgrades, - -- and try to be robust. - & "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes" - - -- Cubietruck - & Apt.installed ["flash-kernel"] - & "/etc/flash-kernel/machine" `File.hasContent` ["Cubietech Cubietruck"] - & Apt.installed ["linux-image-armmp"] + + & cubietech_Cubietruck + & hasPartition + ( partition EXT2 + `mountedAt` "/boot" + `partLocation` Beginning + `setSize` MegaBytes 200 + ) + & hasPartition + ( partition EXT4 + `mountedAt` "/" + `addFreeSpace` MegaBytes 500 + ) + & Apt.installed ["firmware-brcm80211"] -- Workaround for https://bugs.debian.org/844056 `requires` File.hasPrivContent "/lib/firmware/brcm/brcmfmac43362-sdio.txt" anyContext `requires` File.dirExists "/lib/firmware/brcm" - - -- No hardware clock - & Apt.serviceInstalledRunning "ntp" + & "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes" + & Apt.serviceInstalledRunning "ntp" -- no hardware clock + & bootstrappedFrom GitRepoOutsideChroot + & Ssh.hostKeys hostContext + [ (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIIS/hDYq1MAxfOBf49htym3BOYlx4Gk9SDpiHjv7u6IC") + ] & JoeySites.homePowerMonitor (User "joey") @@ -209,19 +213,13 @@ honeybee = host "honeybee.kitenet.net" $ props & Apt.installed ["mtr-tiny", "iftop", "screen"] & Postfix.satellite - & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer - GitAnnexBuilder.armAutoBuilder - Unstable ARMEL Nothing (Cron.Times "15 10 * * *") "10h") - -- Disabled because it does not work, and the old systemd - -- in the container uses a ton of CPU - ! Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer - GitAnnexBuilder.stackAutoBuilder - (Stable "jessie") ARMEL (Just "ancient") weekdays "10h") + & check (not <$> inChroot) (setupRevertableProperty autobuilder) -- In case compiler needs more than available ram & Apt.serviceInstalledRunning "swapspace" where - weekdays = Cron.Times "15 10 * * 2-5" - -- weekends = Cron.Times "15 10 * * 6-7" + autobuilder = Systemd.nspawned $ GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.armAutoBuilder + Unstable ARMEL Nothing (Cron.Times "15 10 * * *") "10h" -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed @@ -565,6 +563,7 @@ standardSystemUnhardened suite arch motd = propertyList "standard system" $ prop & osDebian suite arch & Hostname.sane & Hostname.searchDomain + & Locale.available "en_US.UTF-8" & File.hasContent "/etc/motd" ("":motd++[""]) & Apt.stdSourcesList `onChange` Apt.upgrade & Apt.cacheCleaned diff --git a/propellor.cabal b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.9.0 +Version: 5.1.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> @@ -111,6 +111,7 @@ Library Propellor.Property.File Propellor.Property.Firejail Propellor.Property.Firewall + Propellor.Property.FlashKernel Propellor.Property.FreeBSD Propellor.Property.FreeBSD.Pkg Propellor.Property.FreeBSD.Poudriere @@ -128,6 +129,7 @@ Library Propellor.Property.Locale Propellor.Property.Logcheck Propellor.Property.Lvm + Propellor.Property.Machine Propellor.Property.Mount Propellor.Property.Network Propellor.Property.Nginx @@ -141,6 +143,7 @@ Library Propellor.Property.Postfix Propellor.Property.PropellorRepo Propellor.Property.Prosody + Propellor.Property.Qemu Propellor.Property.Reboot Propellor.Property.Restic Propellor.Property.Rsync @@ -154,6 +157,7 @@ Library Propellor.Property.Systemd.Core Propellor.Property.Timezone Propellor.Property.Tor + Propellor.Property.Uboot Propellor.Property.Unbound Propellor.Property.User Propellor.Property.Uwsgi diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs @@ -80,7 +80,7 @@ buildCommand bs = intercalate " && " (go (getBuilder bs)) where go Cabal = [ "cabal configure" - , "cabal build propellor-config" + , "cabal build -j1 propellor-config" , "ln -sf dist/build/propellor-config/propellor-config propellor" ] go Stack = @@ -280,7 +280,9 @@ cabalBuild msys = do boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))] <&&> cabal ["configure"] ) - cabal_build = cabal ["build", "propellor-config"] + -- The -j1 is to only run one job at a time -- in some situations, + -- eg in qemu, ghc does not run reliably in parallel. + cabal_build = cabal ["build", "-j1", "propellor-config"] stackBuild :: Maybe System -> IO Bool stackBuild _msys = do diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs @@ -102,7 +102,7 @@ onlyProcess lockfile a = bracket lock unlock (const a) `catchIO` const alreadyrunning return l unlock = closeFd - alreadyrunning = error "Propellor is already running on this host!" + alreadyrunning = giveup "Propellor is already running on this host!" -- | Chains to a propellor sub-Process, forwarding its output on to the -- display, except for the last line which is a Result. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs @@ -32,6 +32,7 @@ module Propellor.Property ( , makeChange , noChange , doNothing + , impossible , endAction -- * Property result checking , UncheckedProperty @@ -62,6 +63,7 @@ import Propellor.Types.ResultCheck import Propellor.Types.MetaTypes import Propellor.Types.Singletons import Propellor.Info +import Propellor.Message import Propellor.EnsureProperty import Utility.Exception import Utility.Monad @@ -364,6 +366,12 @@ noChange = return NoChange doNothing :: SingI t => Property (MetaTypes t) doNothing = mempty +-- | In situations where it's not possible to provide a property that +-- works, this can be used to make a property that always fails with an +-- error message you provide. +impossible :: SingI t => String -> Property (MetaTypes t) +impossible msg = property "impossible" $ errorMessage msg + -- | Registers an action that should be run at the very end, after -- propellor has checks all the properties of a host. endAction :: Desc -> (Result -> Propellor Result) -> Propellor () diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs @@ -501,12 +501,16 @@ dpkgStatus = "/var/lib/dpkg/status" -- | Set apt's proxy proxy :: Url -> Property (HasInfo + DebianLike) -proxy u = tightenTargets $ - proxyInfo `before` proxyConfig `describe` desc +proxy u = setInfoProperty (proxy' u) (proxyInfo u) where - proxyInfo = pureInfoProperty desc (InfoVal (HostAptProxy u)) - proxyConfig = "/etc/apt/apt.conf.d/20proxy" `File.hasContent` + proxyInfo = toInfo . InfoVal . HostAptProxy + +proxy' :: Url -> Property DebianLike +proxy' u = tightenTargets $ + "/etc/apt/apt.conf.d/20proxy" `File.hasContent` [ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ] + `describe` desc + where desc = (u ++ " apt proxy selected") -- | Cause apt to proxy downloads via an apt cacher on localhost diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs @@ -9,7 +9,6 @@ module Propellor.Property.Chroot ( ChrootBootstrapper(..), Debootstrapped(..), ChrootTarball(..), - noServices, inChroot, exposeTrueLocaldir, -- * Internal use @@ -32,7 +31,6 @@ import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Property.File as File import qualified Propellor.Shim as Shim import Propellor.Property.Mount -import Utility.FileMode import Utility.Split import qualified Data.Map as M @@ -257,26 +255,6 @@ mungeloc = replace "/" "_" chrootDesc :: Chroot -> String -> String chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc --- | Adding this property to a chroot prevents daemons and other services --- from being started, which is often something you want to prevent when --- building a chroot. --- --- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d> --- script that does not let any daemons be started by packages that use --- invoke-rc.d. Reverting the property removes the script. --- --- This property has no effect on non-Debian systems. -noServices :: RevertableProperty UnixLike UnixLike -noServices = setup <!> teardown - where - f = "/usr/sbin/policy-rc.d" - script = [ "#!/bin/sh", "exit 101" ] - setup = combineProperties "no services started" $ toProps - [ File.hasContent f script - , File.mode f (combineModes (readModes ++ executeModes)) - ] - teardown = File.notPresent f - -- | Check if propellor is currently running within a chroot. -- -- This allows properties to check and avoid performing actions that diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.Debootstrap ( Url, DebootstrapConfig(..), @@ -6,12 +8,12 @@ module Propellor.Property.Debootstrap ( extractSuite, installed, sourceInstall, - programPath, ) where import Propellor.Base import qualified Propellor.Property.Apt as Apt import Propellor.Property.Chroot.Util +import Propellor.Property.Qemu import Utility.Path import Utility.FileMode @@ -29,6 +31,7 @@ data DebootstrapConfig | MinBase | BuilddD | DebootstrapParam String + | UseEmulation | DebootstrapConfig :+ DebootstrapConfig deriving (Show) @@ -41,15 +44,41 @@ toParams DefaultConfig = [] toParams MinBase = [Param "--variant=minbase"] toParams BuilddD = [Param "--variant=buildd"] toParams (DebootstrapParam p) = [Param p] +toParams UseEmulation = [] toParams (c1 :+ c2) = toParams c1 <> toParams c2 +useEmulation :: DebootstrapConfig -> Bool +useEmulation UseEmulation = True +useEmulation (a :+ b) = useEmulation a || useEmulation b +useEmulation _ = False + -- | Builds a chroot in the given directory using debootstrap. -- -- The System can be any OS and architecture that debootstrap -- and the kernel support. +-- +-- When the System is architecture that the kernel does not support, +-- it can still be bootstrapped using emulation. This is determined +-- by checking `supportsArch`, or can be configured with `UseEmulation`. +-- +-- When emulation is used, the chroot will have an additional binary +-- installed in it. To get a completelty clean chroot (eg for producing a +-- bootable disk image), use the `removeHostEmulationBinary` property. built :: FilePath -> System -> DebootstrapConfig -> Property Linux -built target system config = built' (setupRevertableProperty installed) target system config +built target system@(System _ targetarch) config = + withOS ("debootstrapped " ++ target) go + where + go w (Just hostos) + | supportsArch hostos targetarch && not (useEmulation config) = + ensureProperty w $ + built' (setupRevertableProperty installed) + target system config + go w _ = ensureProperty w $ do + let p = setupRevertableProperty foreignBinariesEmulated + `before` setupRevertableProperty installed + built' p target system (config :+ UseEmulation) +-- | Like `built`, but uses the provided Property to install debootstrap. built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux built' installprop target system@(System _ arch) config = go `before` oldpermfix @@ -68,7 +97,9 @@ built' installprop target system@(System _ arch) config = , Param suite , Param target ] - cmd <- fromMaybe "debootstrap" <$> programPath + cmd <- if useEmulation config + then pure "qemu-debootstrap" + else fromMaybe "debootstrap" <$> programPath de <- standardPathEnv ifM (boolSystemEnv cmd params (Just de)) ( return MadeChange diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs @@ -13,6 +13,8 @@ module Propellor.Property.DiskImage ( VirtualBoxPointer(..), imageBuilt, imageRebuilt, + imageBuiltFor, + imageRebuiltFor, imageBuiltFrom, imageExists, Grub.BIOS(..), @@ -24,9 +26,12 @@ import Propellor.Property.Chroot (Chroot) import Propellor.Property.Chroot.Util (removeChroot) import Propellor.Property.Mount import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Property.Service as Service import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Qemu as Qemu +import qualified Propellor.Property.FlashKernel as FlashKernel import Propellor.Property.Parted import Propellor.Property.Fstab (SwapPartition(..), genFstab) import Propellor.Property.Partition @@ -101,7 +106,7 @@ instance DiskImage VirtualBoxPointer where -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process. -- --- Note that the `Chroot.noServices` property is automatically added to the +-- Note that the `Service.noServices` property is automatically added to the -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image. @@ -131,36 +136,59 @@ instance DiskImage VirtualBoxPointer where -- > & User.hasPassword (User "demo") -- > & User.hasDesktopGroups (User "demo") -- > & ... +imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt = imageBuilt' False + +-- | Like 'imageBuilt', but the chroot is deleted and rebuilt from scratch +-- each time. This is more expensive, but useful to ensure reproducible +-- results when the properties of the chroot have been changed. +imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageRebuilt = imageBuilt' True + +-- | Create a bootable disk image for a Host. -- --- This can also be used with `Chroot.hostChroot` to build a disk image --- that has all the properties of a Host. For example: +-- This works just like 'imageBuilt', but partition table is +-- determined by looking at the Host's 'hasPartitionTableType', +-- `hasPartition', and 'adjustPartition' properties. +-- +-- For example: -- -- > foo :: Host -- > foo = host "foo.example.com" $ props --- > & imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img") --- > (hostChroot bar (Debootstrapped mempty)) --- > MSDOS --- > [ partition EXT2 `mountedAt` "/boot" --- > `setFlag` BootFlag --- > , partition EXT4 `mountedAt` "/" --- > `addFreeSpace` MegaBytes 5000 --- > , swapPartition (MegaBytes 256) --- > ] +-- > & imageBuiltFor bar +-- > (RawDiskImage "/srv/diskimages/bar-disk.img") +-- > (Debootstrapped mempty) -- > -- > bar :: Host -- > bar = host "bar.example.com" $ props +-- > & hasPartiton +-- > ( partition EXT2 +-- > `mountedAt` "/boot" +-- > `partLocation` Beginning +-- > `addFreeSpace` MegaBytes 150 +-- > ) +-- > & hasPartiton +-- > ( partition EXT4 +-- > `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 500 +-- > ) -- > & osDebian Unstable X86_64 -- > & Apt.installed ["linux-image-amd64"] -- > & Grub.installed PC -- > & hasPassword (User "root") -imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux -imageBuilt = imageBuilt' False +imageBuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuiltFor = imageBuiltFor' False --- | Like 'built', but the chroot is deleted and rebuilt from scratch each --- time. This is more expensive, but useful to ensure reproducible results --- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux -imageRebuilt = imageBuilt' True +-- | Like 'imageBuiltFor', but the chroot is deleted and rebuilt from +-- scratch each time. +imageRebuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux +imageRebuiltFor = imageBuiltFor' False + +imageBuiltFor' :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Bool -> Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuiltFor' rebuild h d bs = + imageBuilt' rebuild d (Chroot.hostChroot h bs) tt pil + where + PartTableSpec tt pil = toPartTableSpec (fromInfo (hostInfo h)) imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt' rebuild img mkchroot tabletype partspec = @@ -183,7 +211,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec = in setContainerProps c $ containerProps c -- Before ensuring any other properties of the chroot, -- avoid starting services. Reverted by imageFinalized. - &^ Chroot.noServices + &^ Service.noServices & cachesCleaned -- Only propagate privdata Info from this chroot, nothing else. propprivdataonly (Chroot.Chroot d b ip h) = @@ -191,8 +219,14 @@ imageBuilt' rebuild img mkchroot tabletype partspec = -- Pick boot loader finalization based on which bootloader is -- installed. final = case fromInfo (containerInfo chroot) of - [GrubInstalled] -> grubBooted [] -> unbootable "no bootloader is installed" + [GrubInstalled] -> grubFinalized + [UbootInstalled p] -> ubootFinalized p + [FlashKernelInstalled] -> flashKernelFinalized + [UbootInstalled p, FlashKernelInstalled] -> + ubootFlashKernelFinalized p + [FlashKernelInstalled, UbootInstalled p] -> + ubootFlashKernelFinalized p _ -> unbootable "multiple bootloaders are installed; don't know which to use" -- | This property is automatically added to the chroot when building a @@ -215,7 +249,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) - let calcsz mnts = maybe defSz fudge . getMountSz szm mnts + let calcsz mnts = maybe defSz fudgeSz . getMountSz szm mnts -- tie the knot! let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts @@ -228,7 +262,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg mkimg' mnts mntopts parttable devs = partitionsPopulated chrootdir mnts mntopts devs `before` - imageFinalized final mnts mntopts devs parttable + imageFinalized final dest mnts mntopts devs parttable rmimg = undoRevertableProperty (buildDiskImage img) `before` undoRevertableProperty (imageExists' dest dummyparttable) dummyparttable = PartTable tabletype [] @@ -351,10 +385,10 @@ imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` -- -- It's ok if the property leaves additional things mounted -- in the partition tree. -type Finalization = (FilePath -> [LoopDev] -> Property Linux) +type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux -imageFinalized final mnts mntopts devs (PartTable _ parts) = +imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux +imageFinalized final img mnts mntopts devs (PartTable _ parts) = property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> go w top `finally` liftIO (unmountall top) @@ -363,7 +397,9 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) = liftIO $ mountall top liftIO $ writefstab top liftIO $ allowservices top - ensureProperty w $ final top devs + ensureProperty w $ + final img top devs + `before` Qemu.removeHostEmulationBinary top -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local @@ -399,18 +435,14 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) = allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d") unbootable :: String -> Finalization -unbootable msg = \_ _ -> property desc $ do +unbootable msg = \_ _ _ -> property desc $ do warningMessage (desc ++ ": " ++ msg) return FailedChange where desc = "image is not bootable" --- | Makes grub be the boot loader of the disk image. --- --- This does not install the grub package. You will need to add --- the `Grub.installed` property to the chroot. -grubBooted :: Finalization -grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev +grubFinalized :: Finalization +grubFinalized _img mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev `describe` "disk image boots using grub" where -- It doesn't matter which loopdev we use; all @@ -420,6 +452,17 @@ grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev (l:_) -> wholeDiskLoopDev l [] -> error "No loop devs provided!" +ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization +ubootFinalized p (RawDiskImage img) mnt _loopdevs = p img mnt + +flashKernelFinalized :: Finalization +flashKernelFinalized _img mnt _loopdevs = FlashKernel.flashKernelMounted mnt + +ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization +ubootFlashKernelFinalized p img mnt loopdevs = + ubootFinalized p img mnt loopdevs + `before` flashKernelFinalized img mnt loopdevs + isChild :: FilePath -> Maybe MountPoint -> Bool isChild mntpt (Just d) | d `equalFilePath` mntpt = False diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -1,33 +1,186 @@ --- | Disk image partition specification and combinators. +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} --- Partitions in disk images default to being sized large enough to hold --- the files that appear in the directory where the partition is to be --- mounted. Plus a fudge factor, since filesystems have some space --- overhead. +-- | Disk image partition specification. module Propellor.Property.DiskImage.PartSpec ( - module Propellor.Types.PartSpec, - module Propellor.Property.DiskImage.PartSpec, - module Propellor.Property.Parted.Types, - module Propellor.Property.Partition, + PartSpec, + Fs(..), + PartSize(..), + partition, + -- * PartSpec combinators + swapPartition, + mountedAt, + addFreeSpace, + setSize, + mountOpt, + errorReadonly, + reservedSpacePercentage, + setFlag, + extended, + -- * Partition properties + -- + -- | These properties do not do any disk partitioning on their own, but + -- the Info they set can be used when building a disk image for a + -- host. + hasPartition, + adjustPartition, + PartLocation(..), + partLocation, + hasPartitionTableType, + TableType(..), + PartInfo, + toPartTableSpec, + PartTableSpec(..) ) where import Propellor.Base import Propellor.Property.Parted import Propellor.Types.PartSpec -import Propellor.Property.Parted.Types +import Propellor.Types.Info import Propellor.Property.Partition (Fs(..)) +import Propellor.Property.Mount --- | Adds additional free space to the partition. +import Data.List (sortBy) +import Data.Ord + +-- | Specifies a partition with a given filesystem. +-- +-- The partition is not mounted anywhere by default; use the combinators +-- below to configure it. +partition :: Monoid t => Fs -> PartSpec t +partition fs = (Nothing, mempty, mkPartition fs, mempty) + +-- | Specifies a swap partition of a given size. +swapPartition :: Monoid t => PartSize -> PartSpec t +swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty) + +-- | Specifies where to mount a partition. +mountedAt :: PartSpec t -> MountPoint -> PartSpec t +mountedAt (_, o, p, t) mp = (Just mp, o, p, t) + +-- | Partitions in disk images default to being sized large enough to hold +-- the files that live in that partition. +-- +-- This adds additional free space to a partition. addFreeSpace :: PartSpec t -> PartSize -> PartSpec t addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t) where p' = \sz -> p (sz <> freesz) --- | Add 2% for filesystem overhead. Rationalle for picking 2%: --- A filesystem with 1% overhead might just sneak by as acceptable. --- Double that just in case. Add an additional 3 mb to deal with --- non-scaling overhead of filesystems (eg, superblocks). --- Add an additional 200 mb for temp files, journals, etc. -fudge :: PartSize -> PartSize -fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) +-- | Specify a fixed size for a partition. +setSize :: PartSpec t -> PartSize -> PartSpec t +setSize (mp, o, p, t) sz = (mp, o, const (p sz), t) + +-- | Specifies a mount option, such as "noexec" +mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t +mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t) + +-- | Mount option to make a partition be remounted readonly when there's an +-- error accessing it. +errorReadonly :: MountOpts +errorReadonly = toMountOpts "errors=remount-ro" + +-- | Sets the percent of the filesystem blocks reserved for the super-user. +-- +-- The default is 5% for ext2 and ext4. Some filesystems may not support +-- this. +reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t +reservedSpacePercentage s percent = adjustp s $ \p -> + p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p } + +-- | Sets a flag on the partition. +setFlag :: PartSpec t -> PartFlag -> PartSpec t +setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } + +-- | Makes a MSDOS partition be Extended, rather than Primary. +extended :: PartSpec t -> PartSpec t +extended s = adjustp s $ \p -> p { partType = Extended } + +adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t +adjustp (mp, o, p, t) f = (mp, o, f . p, t) + +data PartInfoVal + = TableTypeInfo TableType + | PartSpecInfo (PartSpec PartLocation) + | AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation) + +newtype PartInfo = PartInfo [PartInfoVal] + deriving (Monoid, Typeable) + +instance IsInfo PartInfo where + propagateInfo _ = PropagateInfo False + +instance Show PartInfo where + show = show . toPartTableSpec + +toPartTableSpec :: PartInfo -> PartTableSpec +toPartTableSpec (PartInfo l) = PartTableSpec tt pil + where + tt = fromMaybe MSDOS $ headMaybe $ reverse $ mapMaybe gettt l + + pil = map convert $ sortBy (comparing location) $ adjust collect + collect = mapMaybe getspartspec l + adjust ps = adjust' ps (mapMaybe getadjust l) + adjust' ps [] = ps + adjust' ps ((mp, f):rest) = adjust' (map (adjustone mp f) ps) rest + adjustone mp f p@(mp', _, _, _) + | Just mp == mp' = f p + | otherwise = p + location (_, _, _, loc) = loc + convert (mp, o, p, _) = (mp, o, p, ()) + + gettt (TableTypeInfo t) = Just t + gettt _ = Nothing + getspartspec (PartSpecInfo ps) = Just ps + getspartspec _ = Nothing + getadjust (AdjustPartSpecInfo mp f) = Just (mp, f) + getadjust _ = Nothing + +-- | Indicates the partition table type of a host. +-- +-- When not specified, the default is MSDOS. +-- +-- For example: +-- +-- > & hasPartitionTableType GPT +hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike) +hasPartitionTableType tt = pureInfoProperty + ("partition table type " ++ show tt) + (PartInfo [TableTypeInfo tt]) + +-- | Indicates that a host has a partition. +-- +-- For example: +-- +-- > & hasPartiton (partition EXT2 `mountedAt` "/boot" `partLocation` Beginning) +-- > & hasPartiton (partition EXT4 `mountedAt` "/") +-- > & hasPartiton (partition EXT4 `mountedAt` "/home" `partLocation` End `reservedSpacePercentage` 0) +hasPartition :: PartSpec PartLocation -> Property (HasInfo + UnixLike) +hasPartition p@(mmp, _, _, _) = pureInfoProperty desc + (PartInfo [PartSpecInfo p]) + where + desc = case mmp of + Just mp -> "has " ++ mp ++ " partition" + Nothing -> "has unmounted partition" + +-- | Adjusts the PartSpec for the partition mounted at the specified location. +-- +-- For example: +-- +-- > & adjustPartition "/boot" (`addFreeSpace` MegaBytes 150) +adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike) +adjustPartition mp f = pureInfoProperty + ("has " ++ mp ++ " adjusted") + (PartInfo [AdjustPartSpecInfo mp f]) + +-- | Indicates partition layout in a disk. Default is somewhere in the +-- middle. +data PartLocation = Beginning | Middle | End + deriving (Eq, Ord) + +instance Monoid PartLocation where + mempty = Middle + mappend _ b = b + +partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation +partLocation (mp, o, p, _) l = (mp, o, p, l) diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs @@ -2,6 +2,7 @@ module Propellor.Property.Fail2Ban where import Propellor.Base import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service import Propellor.Property.ConfFile @@ -13,18 +14,47 @@ reloaded = Service.reloaded "fail2ban" type Jail = String +type Filter = String + +type Action = String + -- | By default, fail2ban only enables the ssh jail, but many others -- are available to be enabled, for example "postfix-sasl" jailEnabled :: Jail -> Property DebianLike -jailEnabled name = jailConfigured name "enabled" "true" +jailEnabled name = jailEnabled' name [] + `onChange` reloaded + +jailEnabled' :: Jail -> [(IniKey, String)] -> Property DebianLike +jailEnabled' name settings = + jailConfigured' name (("enabled", "true") : settings) `onChange` reloaded -- | Configures a jail. For example: -- --- > jailConfigured "sshd" "port" "2222" +-- > jailConfigured' "sshd" [("port", "2222")] +jailConfigured' :: Jail -> [(IniKey, String)] -> Property UnixLike +jailConfigured' name settings = propertyList ("jail \"" ++ name ++ "\" configuration") $ props + -- removes .conf files added by old versions of Fail2Ban properties + & File.notPresent (oldJailConfFile name) + & jailConfFile name `iniFileContains` [(name, settings)] + +-- | Adds a setting to a given jail. For example: +-- +-- > jailConfigured "sshd" "port" "2222" jailConfigured :: Jail -> IniKey -> String -> Property UnixLike -jailConfigured name key value = - jailConfFile name `containsIniSetting` (name, key, value) +jailConfigured name key value = propertyList ("jail \"" ++ name ++ "\" configuration") $ props + -- removes .conf files added by old versions of Fail2Ban properties + & File.notPresent (oldJailConfFile name) + & jailConfFile name `containsIniSetting` (name, key, value) + +oldJailConfFile :: Jail -> FilePath +oldJailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf" jailConfFile :: Jail -> FilePath -jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf" +jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".local" + +filterConfFile :: Filter -> FilePath +filterConfFile name = "/etc/fail2ban/filter.d/" ++ name ++ ".local" + +actionConfFile :: Action -> FilePath +actionConfFile name = "/etc/fail2ban/action.d/" ++ name ++ ".local" diff --git 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. -- --- Does not overwrite regular files or directories. -isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike -link `isSymlinkedTo` (LinkTarget target) = property desc $ - go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) +-- Revert to ensure no symlink is present. +-- +-- Does not overwrite or delete regular files or directories. +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/Firejail.hs b/src/Propellor/Property/Firejail.hs @@ -26,6 +26,6 @@ jailed ps = mconcat (map jailed' ps) `requires` installed `describe` unwords ("firejail jailed":ps) -jailed' :: String -> Property UnixLike +jailed' :: String -> RevertableProperty UnixLike UnixLike jailed' p = ("/usr/local/bin" </> p) `File.isSymlinkedTo` File.LinkTarget "/usr/bin/firejail" diff --git a/src/Propellor/Property/FlashKernel.hs b/src/Propellor/Property/FlashKernel.hs @@ -0,0 +1,63 @@ +-- | Make ARM systems bootable using Debian's flash-kernel package. + +module Propellor.Property.FlashKernel where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.Mount +import Propellor.Types.Bootloader +import Propellor.Types.Info + +-- | A machine name, such as "Cubietech Cubietruck" or "Olimex A10-OLinuXino-LIME" +-- +-- flash-kernel supports many different machines, +-- see its file /usr/share/flash-kernel/db/all.db for a list. +type Machine = String + +-- | Uses flash-kernel to make a machine bootable. +-- +-- Before using this, an appropriate kernel needs to already be installed, +-- and on many machines, u-boot needs to be installed too. +installed :: Machine -> Property (HasInfo + DebianLike) +installed machine = setInfoProperty go (toInfo [FlashKernelInstalled]) + where + go = "/etc/flash-kernel/machine" `File.hasContent` [machine] + `onChange` (cmdProperty "flash-kernel" [] `assume` MadeChange) + `requires` File.dirExists "/etc/flash-kernel" + `requires` Apt.installed ["flash-kernel"] + +-- | Runs flash-kernel in the system mounted at a particular directory. +flashKernelMounted :: FilePath -> Property Linux +flashKernelMounted mnt = combineProperties desc $ props + -- remove mounts that are done below to make sure the right thing + -- gets mounted + & cleanupmounts + & bindMount "/dev" (inmnt "/dev") + & mounted "proc" "proc" (inmnt "/proc") mempty + & mounted "sysfs" "sys" (inmnt "/sys") mempty + -- update the initramfs so it gets the uuid of the root partition + & inchroot "update-initramfs" ["-u"] + `assume` MadeChange + & inchroot "flash-kernel" [] + `assume` MadeChange + & cleanupmounts + where + desc = "flash-kernel run" + + -- cannot use </> since the filepath is absolute + inmnt f = mnt ++ f + + inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) + + cleanupmounts :: Property Linux + cleanupmounts = property desc $ liftIO $ do + cleanup "/sys" + cleanup "/proc" + cleanup "/dev" + return NoChange + where + cleanup m = + let mp = inmnt m + in whenM (isMounted mp) $ + umountLazy mp diff --git a/src/Propellor/Property/Machine.hs b/src/Propellor/Property/Machine.hs @@ -0,0 +1,201 @@ +-- | Machine-specific properties. +-- +-- Many embedded computers have their own special configuration needed +-- to use them. Rather than needing to hunt down documentation about the +-- kernel, bootloader, etc for a given machine, if there's a property +-- in here for your machine, you can simply use it. +-- +-- Not all machine properties have been tested yet. If one flagged as +-- untested and you find it works, please let us know. +-- +-- You will need to configure the `Host` with the right `Architecture` +-- for the machine. These properties do test at runtime that a supported +-- Architecture was selected. +-- +-- Sometimes non-free firmware is needed to use a board. If the board won't +-- be functional at all without it, its property will include the non-free +-- firmware, but if the non-free firmware is only needed for non-critical +-- functionality, it won't be included. +-- +-- Example: Building a disk image for a Marvell SheevaPlug +-- +-- This defines a Host "sheeva" that is a Marvell SheevaPlug. +-- A bootable disk image for "sheeva" is built on another machine +-- "darkstar", which can be eg an Intel laptop running Debian. +-- +-- > import Propellor.Property.Machine +-- > import Propellor.Property.DiskImage +-- > +-- > sheeva :: Host +-- > sheeva = host "sheeva.example.com" $ props +-- > & osDebian Unstable ARMEL +-- > & marvell_SheevaPlug Marvell_SheevaPlug_SDCard +-- > & hasPartition +-- > ( partition EXT4 +-- > `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 2048 +-- > ) +-- > +-- > darkstar :: Host +-- > darkstar = host "darkstar.example.com" $ props +-- > & imageBuiltFor sheeva +-- > (RawDiskImage "/srv/sheeva-disk.img") +-- > (Debootstrapped mempty) + +module Propellor.Property.Machine ( + -- * ARM boards + Marvell_SheevaPlug_BootDevice(..), + marvell_SheevaPlug, + cubietech_Cubietruck, + olimex_A10_OLinuXino_LIME, + -- * ARM boards (untested) + cubietech_Cubieboard, + cubietech_Cubieboard2, + lemaker_Banana_Pi, + lemaker_Banana_Pro, + olimex_A10s_OLinuXino_Micro, + olimex_A20_OLinuXino_LIME, + olimex_A20_OLinuXino_LIME2, + olimex_A20_OLinuXino_Micro, + olimex_A20_SOM_EVB, + linkSprite_pcDuino3_Nano, +) where + +import Propellor.Base +import Propellor.Types.Core +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.FlashKernel as FlashKernel +import qualified Propellor.Property.Uboot as Uboot +import Propellor.Property.DiskImage.PartSpec + +data Marvell_SheevaPlug_BootDevice + = Marvell_SheevaPlug_SDCard + | Marvell_SheevaPlug_ESATA + +-- | Marvell SheevaPlug +-- +-- This includes a small EXT2 formatted /boot partition. +-- +-- Note that u-boot may need to be upgraded manually, and will need to be +-- configured to boot from the SD card or eSATA. See +-- https://www.cyrius.com/debian/kirkwood/sheevaplug/install/ +marvell_SheevaPlug :: Marvell_SheevaPlug_BootDevice -> Property (HasInfo + DebianLike) +marvell_SheevaPlug bd = fk + `requires` marvell + `requires` hasPartition bootpart + where + fk = case bd of + Marvell_SheevaPlug_SDCard -> + FlashKernel.installed "Marvell SheevaPlug Reference Board" + Marvell_SheevaPlug_ESATA -> + FlashKernel.installed "Marvell eSATA SheevaPlug Reference Board" + -- The boot loader needs an EXT2 boot partition, which comes + -- first. Add some free space to allow for additional kernel images + -- and initrds. + bootpart :: PartSpec PartLocation + bootpart = partition EXT2 + `mountedAt` "/boot" + `partLocation` Beginning + `addFreeSpace` MegaBytes 150 + +-- | Cubietech Cubietruck +-- +-- Wifi needs non-free firmware-brcm80211, which is not installed by +-- this property. Also, see https://bugs.debian.org/844056 +cubietech_Cubietruck :: Property (HasInfo + DebianLike) +cubietech_Cubietruck = FlashKernel.installed "Cubietech Cubietruck" + `requires` sunixi "Cubietruck" + `requires` lpae + +-- | Cubietech Cubieboard (untested) +cubietech_Cubieboard :: Property (HasInfo + DebianLike) +cubietech_Cubieboard = FlashKernel.installed "Cubietech Cubieboard" + `requires` sunixi "Cubieboard" + `requires` armmp + +-- | Cubietech Cubieboard2 (untested) +cubietech_Cubieboard2 :: Property (HasInfo + DebianLike) +cubietech_Cubieboard2 = FlashKernel.installed "Cubietech Cubieboard2" + `requires` sunixi "Cubieboard2" + `requires` lpae + +-- | LeMaker Banana Pi +lemaker_Banana_Pi :: Property (HasInfo + DebianLike) +lemaker_Banana_Pi = FlashKernel.installed "LeMaker Banana Pi" + `requires` sunixi "Bananapi" + `requires` lpae + +-- | LeMaker Banana Pro (untested) +lemaker_Banana_Pro :: Property (HasInfo + DebianLike) +lemaker_Banana_Pro = FlashKernel.installed "LeMaker Banana Pro" + `requires` sunixi "Bananapro" + `requires` lpae + +-- | Olimex A10-OLinuXino-LIME +olimex_A10_OLinuXino_LIME :: Property (HasInfo + DebianLike) +olimex_A10_OLinuXino_LIME = FlashKernel.installed "Olimex A10-OLinuXino-LIME" + `requires` sunixi "A10-OLinuXino-Lime" + `requires` armmp + +-- | Olimex A10s-Olinuxino Micro (untested) +olimex_A10s_OLinuXino_Micro :: Property (HasInfo + DebianLike) +olimex_A10s_OLinuXino_Micro = FlashKernel.installed "Olimex A10s-Olinuxino Micro" + `requires` sunixi "A10s-OLinuXino-M" + `requires` armmp + +-- | Olimex A20-OlinuXino-LIME (untested) +olimex_A20_OLinuXino_LIME :: Property (HasInfo + DebianLike) +olimex_A20_OLinuXino_LIME = FlashKernel.installed "Olimex A20-OLinuXino-LIME" + `requires` sunixi "A20-OLinuXino-Lime" + `requires` lpae + +-- | Olimex A20-OlinuXino-LIME2 (untested) +olimex_A20_OLinuXino_LIME2 :: Property (HasInfo + DebianLike) +olimex_A20_OLinuXino_LIME2 = FlashKernel.installed "Olimex A20-OLinuXino-LIME2" + `requires` sunixi "A20-OLinuXino-Lime2" + `requires` lpae + +-- | Olimex A20-Olinuxino Micro (untested) +olimex_A20_OLinuXino_Micro :: Property (HasInfo + DebianLike) +olimex_A20_OLinuXino_Micro = FlashKernel.installed "Olimex A20-Olinuxino Micro" + `requires` sunixi "A20-OLinuXino-MICRO" + `requires` lpae + +-- | Olimex A20-SOM-EVB (untested) +olimex_A20_SOM_EVB :: Property (HasInfo + DebianLike) +olimex_A20_SOM_EVB = FlashKernel.installed "Olimex A20-Olimex-SOM-EVB" + `requires` sunixi "A20-Olimex-SOM-EVB" + `requires` lpae + +-- | LinkSprite pcDuino Nano (untested) +-- +-- Needs non-free firmware, see +-- https://wiki.debian.org/InstallingDebianOn/Allwinner +linkSprite_pcDuino3_Nano :: Property (HasInfo + DebianLike) +linkSprite_pcDuino3_Nano = FlashKernel.installed "LinkSprite pcDuino3 Nano" + `requires` sunixi "Linksprite_pcDuino3" + `requires` lpae + +sunixi :: Uboot.BoardName -> Property (HasInfo + DebianLike) +sunixi boardname = Uboot.sunxi boardname + `requires` Apt.installed + [ "firmware-linux-free" + , "sunxi-tools" + ] + +armmp :: Property DebianLike +armmp = checkArchitecture [ARMHF, ARMEL] $ + Apt.installed ["linux-image-armmp"] + +lpae :: Property DebianLike +lpae = checkArchitecture [ARMHF, ARMEL] $ + Apt.installed ["linux-image-armmp-lpae"] + +marvell :: Property DebianLike +marvell = checkArchitecture [ARMEL] $ + Apt.installed ["linux-image-marvell"] + +checkArchitecture :: [Architecture] -> Property DebianLike -> Property DebianLike +checkArchitecture as p = withOS (getDesc p) $ \w o -> case o of + (Just (System _ arch)) | arch `elem` as -> ensureProperty w p + _ -> error $ "Machine needs architecture to be one of: " ++ show as diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs @@ -90,18 +90,18 @@ mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target) -- | Filesystem type mounted at a given location. getFsType :: MountPoint -> IO (Maybe FsType) -getFsType = findmntField "fstype" +getFsType p = findmntField "fstype" [p] -- | Mount options for the filesystem mounted at a given location. getFsMountOpts :: MountPoint -> IO MountOpts getFsMountOpts p = maybe mempty toMountOpts - <$> findmntField "fs-options" p + <$> findmntField "fs-options" [p] type UUID = String -- | UUID of filesystem mounted at a given location. getMountUUID :: MountPoint -> IO (Maybe UUID) -getMountUUID = findmntField "uuid" +getMountUUID p = findmntField "uuid" [p] -- | UUID of a device getSourceUUID :: Source -> IO (Maybe UUID) @@ -111,7 +111,7 @@ type Label = String -- | Label of filesystem mounted at a given location. getMountLabel :: MountPoint -> IO (Maybe Label) -getMountLabel = findmntField "label" +getMountLabel p = findmntField "label" [p] -- | Label of a device getSourceLabel :: Source -> IO (Maybe UUID) @@ -119,12 +119,16 @@ getSourceLabel = blkidTag "LABEL" -- | Device mounted at a given location. getMountSource :: MountPoint -> IO (Maybe Source) -getMountSource = findmntField "source" +getMountSource p = findmntField "source" [p] -findmntField :: String -> FilePath -> IO (Maybe String) -findmntField field mnt = catchDefaultIO Nothing $ +-- | Device that a given path is located within. +getMountContaining :: FilePath -> IO (Maybe Source) +getMountContaining p = findmntField "source" ["-T", p] + +findmntField :: String -> [String] -> IO (Maybe String) +findmntField field ps = catchDefaultIO Nothing $ headMaybe . filter (not . null) . lines - <$> readProcess "findmnt" ["-n", mnt, "--output", field] + <$> readProcess "findmnt" ("-n" : ps ++ ["--output", field]) blkidTag :: String -> Source -> IO (Maybe String) blkidTag tag dev = catchDefaultIO Nothing $ diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs @@ -21,13 +21,14 @@ module Propellor.Property.Parted ( parted, Eep(..), installed, - -- * PartSpec combinators + -- * Partition table sizing calcPartTable, DiskSize(..), DiskPart, - module Propellor.Types.PartSpec, DiskSpaceUse(..), useDiskSpace, + defSz, + fudgeSz, ) where import Propellor.Base @@ -35,7 +36,7 @@ import Propellor.Property.Parted.Types import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Property.Partition as Partition -import Propellor.Types.PartSpec +import Propellor.Types.PartSpec (PartSpec) import Utility.DataUnits import System.Posix.Files @@ -160,3 +161,19 @@ instance Monoid DiskPart -- (less all fixed size partitions), or the remaining space in the disk. useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse) + +-- | Default partition size when not otherwize specified is 128 MegaBytes. +defSz :: PartSize +defSz = MegaBytes 128 + +-- | When a partition is sized to fit the files that live in it, +-- this fudge factor is added to the size of the files. This is necessary +-- since filesystems have some space overhead. +-- +-- Add 2% for filesystem overhead. Rationalle for picking 2%: +-- A filesystem with 1% overhead might just sneak by as acceptable. +-- Double that just in case. Add an additional 3 mb to deal with +-- non-scaling overhead of filesystems (eg, superblocks). +-- Add an additional 200 mb for temp files, journals, etc. +fudgeSz :: PartSize -> PartSize +fudgeSz (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module Propellor.Property.PropellorRepo where import Propellor.Base @@ -24,4 +26,4 @@ hasOriginUrl u = setInfoProperty p (toInfo (InfoVal (OriginUrl u))) else makeChange $ setRepoUrl u newtype OriginUrl = OriginUrl String - deriving (Show) + deriving (Show, Typeable) diff --git a/src/Propellor/Property/Qemu.hs b/src/Propellor/Property/Qemu.hs @@ -0,0 +1,49 @@ +module Propellor.Property.Qemu where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt + +-- | Installs qemu user mode emulation binaries, built statically, +-- which allow foreign binaries to run directly. +foreignBinariesEmulated :: RevertableProperty Linux Linux +foreignBinariesEmulated = (setup <!> cleanup) + `describe` "foreign binary emulation" + where + setup = Apt.installed p `pickOS` unsupportedOS + cleanup = Apt.removed p `pickOS` unsupportedOS + p = ["qemu-user-static"] + +-- | Removes qemu user mode emulation binary for the host CPU. +-- This binary is copied into a chroot by qemu-debootstrap, and is not +-- part of any package. +-- +-- Note that removing the binary will prevent using the chroot on the host +-- system. +-- +-- The FilePath is the path to the top of the chroot. +removeHostEmulationBinary :: FilePath -> Property Linux +removeHostEmulationBinary top = tightenTargets $ + scriptProperty ["rm -f " ++ top ++ "/usr/bin/qemu-*-static"] + `assume` MadeChange + +-- | Check if the given System supports an Architecture. +-- +-- For example, on Debian, X86_64 supports X86_32, and vice-versa. +supportsArch :: System -> Architecture -> Bool +supportsArch (System os a) b + | a == b = True + | otherwise = case os of + Debian _ _ -> debianlike + Buntish _ -> debianlike + -- don't know about other OS's + _ -> False + where + debianlike = + let l = + [ (X86_64, X86_32) + , (ARMHF, ARMEL) + , (PPC, PPC64) + , (SPARC, SPARC64) + , (S390, S390X) + ] + in elem (a, b) l || elem (b, a) l diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs @@ -6,31 +6,38 @@ 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 -> & Sbuild.usableBy (User "spwhitton") -> & Schroot.overlaysInTmpfs +> mybox = host "mybox.example.com" $ props +> & osDebian (Stable "stretch") X86_64 +> & Apt.useLocalCacher +> & sidSchrootBuilt +> & Sbuild.usableBy (User "spwhitton") +> & Schroot.overlaysInTmpfs +> where +> sidSchrootBuilt = Sbuild.built Sbuild.UseCcache $ props +> & osDebian Unstable X86_32 +> & Sbuild.update `period` Weekly (Just 1) +> & Sbuild.useHostProxy mybox 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 +48,17 @@ 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, + -- * Properties for use inside sbuild schroots + update, + useHostProxy, -- * Global sbuild configuration -- blockNetwork, - installed, keypairGenerated, keypairInsecurelyGenerated, usableBy, @@ -82,157 +66,125 @@ 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 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 - --- | 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 -> emitError + Just s@(System _ arch) -> case extractSuite s of + Nothing -> emitError + 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') + + 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 - 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 + & 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 - ) - - -- 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 - -- local apt-cacher-ng instance - -- - -- (if we didn't assume that the apt proxy does some sort of caching, - -- we'd need to complicate the Apt.HostAptProxy type to indicate whether - -- the proxy caches, and if it doesn't, set up apt-cacher-ng as an - -- intermediary proxy between the chroot's apt and the Apt.HostAptProxy - -- proxy. This complexity is more likely to cause problems than help - -- anyone) - 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") + 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 - 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 ++ "\";" ] + 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) -- if we're building a sid chroot, add useful aliases -- In order to avoid more than one schroot getting the same aliases, we -- 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 +201,27 @@ 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 (Props schrootProps) + schrootProps = + ps ++ [toChildProperty Apt.stdSourcesList + , toChildProperty $ 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 +234,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 +245,41 @@ 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 +-- This replaces use of sbuild-update(1). +update :: Property DebianLike +update = Apt.update `before` Apt.upgrade `before` Apt.autoRemove --- 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'. +-- | Ensure that an sbuild schroot uses the host's Apt proxy. -- --- 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 +-- This property is standardly used when the host has 'Apt.useLocalCacher'. +useHostProxy :: Host -> Property DebianLike +useHostProxy h = property' "use host's apt proxy" $ \w -> + -- Note that we can't look at getProxyInfo outside the property, + -- as that would loop, but it's ok to look at it inside the + -- property. Thus the slightly strange construction here. + case getProxyInfo of + Just (Apt.HostAptProxy u) -> ensureProperty w (Apt.proxy' u) + Nothing -> noChange where - new = schrootConf s - dir = takeDirectory new - tempPrefix = dir </> suite ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-" - munge = replace "-propellor]" "-sbuild]" - + getProxyInfo = fromInfoVal . fromInfo . hostInfo $ h 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,10 +410,11 @@ 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 Just (System _ hostArch) -> - suite == "unstable" && hostArch == arch + let hostArch' = architectureToDebianArchString hostArch + in suite == "unstable" && hostArch' == arch diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module Propellor.Property.Service where import Propellor.Base +import Propellor.Types.Info +import qualified Propellor.Property.File as File +import Utility.FileMode type ServiceName = String @@ -21,7 +26,34 @@ reloaded :: ServiceName -> Property DebianLike reloaded = signaled "reload" "reloaded" signaled :: String -> Desc -> ServiceName -> Property DebianLike -signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc) +signaled cmd desc svc = check (not <$> servicesDisabled) $ + tightenTargets $ p `describe` (desc ++ " " ++ svc) where p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] `assume` NoChange + +-- | This property prevents daemons and other services from being started, +-- which is often something you want to prevent when building a chroot. +-- +-- When this is set, `running` and `restarted` will not start services. +-- +-- On Debian this installs a </usr/sbin/policy-rc.d> script to further +-- prevent any packages that get installed from starting daemons. +-- Reverting the property removes the script. +noServices :: RevertableProperty (HasInfo + UnixLike) UnixLike +noServices = (setup `setInfoProperty` toInfo (InfoVal NoServices)) <!> teardown + where + f = "/usr/sbin/policy-rc.d" + script = [ "#!/bin/sh", "exit 101" ] + setup = combineProperties "no services started" $ toProps + [ File.hasContent f script + , File.mode f (combineModes (readModes ++ executeModes)) + ] + teardown = File.notPresent f + +-- | Check if the noServices property is in effect. +servicesDisabled :: Propellor Bool +servicesDisabled = isJust . fromInfoVal + <$> (askInfo :: Propellor (InfoVal NoServices)) + +data NoServices = NoServices deriving (Eq, Show, Typeable) diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -119,10 +119,10 @@ standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInf standardAutoBuilder suite arch flavor = propertyList "standard git-annex autobuilder" $ props & osDebian suite arch - & buildDepsApt & Apt.stdSourcesList & Apt.unattendedUpgrades & Apt.cacheCleaned + & buildDepsApt & User.accountFor (User builduser) & tree (architectureToDebianArchString arch) flavor @@ -177,13 +177,10 @@ armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + D armAutoBuilder suite arch flavor = propertyList "arm git-annex autobuilder" $ props & standardAutoBuilder suite arch flavor - & buildDepsNoHaskellLibs + & buildDepsApt -- Works around ghc crash with parallel builds on arm. & (homedir </> ".cabal" </> "config") `File.lacksLine` "jobs: $ncpus" - -- Install patched haskell packages for portability to - -- arm NAS's using old kernel versions. - & haskellPkgsInstalled "linux" androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container androidAutoBuilderContainer crontimes timeout = diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -20,7 +20,14 @@ installedFor user@(User u) = check (not <$> hasGitDir user) $ moveout tmpdir home , property "rmdir" $ makeChange $ void $ catchMaybeIO $ removeDirectory tmpdir - , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"] + , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile"] + `assume` MadeChange + -- Set HOSTNAME so that this sees the right + -- hostname when run in a chroot with a different + -- hostname than the current one. + , userScriptProperty user ["HOSTNAME=$(cat /etc/hostname) bin/mr checkout"] + `assume` MadeChange + , userScriptProperty user ["bin/fixups"] `assume` MadeChange ] moveout tmpdir home = do diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -595,19 +595,16 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props [ "#!/bin/sh" , "# deployed with propellor" , "set -e" - , "pass=$HOME/.pine-password" - , "if [ ! -e $pass ]; then" - , "\ttouch $pass" - , "fi" - , "chmod 600 $pass" - , "exec alpine -passfile $pass \"$@\"" + , "exec alpine \"$@\"" ] `onChange` (pinescript `File.mode` combineModes (readModes ++ executeModes)) `describe` "pine wrapper script" + -- Make pine use dovecot pipe to read maildir. & "/etc/pine.conf" `File.hasContent` [ "# deployed with propellor" - , "inbox-path={localhost/novalidate-cert/NoRsh}inbox" + , "inbox-path={localhost}inbox" + , "rsh-command=/usr/lib/dovecot/imap" ] `describe` "pine configured to use local imap server" @@ -912,16 +909,20 @@ alarmClock oncalendar (User user) command = combineProperties "goodmorning timer homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike) homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props & Apache.installed - & Apt.installed ["python", "python-pymodbus"] + & Apt.installed ["python", "python-pymodbus", "rrdtool", "rsync"] & File.ownerGroup "/var/www/html" user (userGroup user) & Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing - `onChange` buildpoller + & buildpoller & Systemd.enabled servicename `requires` serviceinstalled `onChange` Systemd.started servicename + & User.hasGroup user (Group "dialout") & Cron.niceJob "homepower upload" (Cron.Times "1 * * * *") user d rsynccommand `requires` Ssh.userKeyAt (Just sshkeyfile) user ctx sshkey + `requires` File.ownerGroup (takeDirectory sshkeyfile) + user (userGroup user) + `requires` File.dirExists (takeDirectory sshkeyfile) where d = "/var/www/html/homepower" sshkeyfile = d </> ".ssh/key" @@ -957,30 +958,34 @@ homeRouter :: Property (HasInfo + DebianLike) homeRouter = propertyList "home router" $ props & Network.static "wlan0" (IPv4 "10.1.1.1") Nothing `requires` Network.cleanInterfacesFile - & Apt.serviceInstalledRunning "hostapd" - `requires` File.hasContent "/etc/hostapd/hostapd.conf" + & Apt.installed ["hostapd"] + & File.hasContent "/etc/hostapd/hostapd.conf" [ "interface=wlan0" , "ssid=house" , "hw_mode=g" , "channel=8" ] - `requires` File.dirExists "/lib/hostapd" - & Apt.serviceInstalledRunning "dnsmasq" - `requires` File.hasContent "/etc/dnsmasq.conf" - [ "domain-needed" - , "bogus-priv" - , "interface=wlan0" - , "domain=kitenet.net" - , "dhcp-range=10.1.1.100,10.1.1.150,24h" - , "no-hosts" - , "address=/honeybee.kitenet.net/10.1.1.1" - ] - `requires` File.hasContent "/etc/resolv.conf" - [ "domain kitenet.net" - , "search kitenet.net" - , "nameserver 8.8.8.8" - , "nameserver 8.8.4.4" - ] + `requires` File.dirExists "/etc/hostapd" + `requires` File.hasContent "/etc/default/hostapd" + [ "DAEMON_CONF=/etc/hostapd/hostapd.conf" ] + `onChange` Service.running "hostapd" + & File.hasContent "/etc/resolv.conf" + [ "domain kitenet.net" + , "search kitenet.net" + , "nameserver 8.8.8.8" + , "nameserver 8.8.4.4" + ] + & Apt.installed ["dnsmasq"] + & File.hasContent "/etc/dnsmasq.conf" + [ "domain-needed" + , "bogus-priv" + , "interface=wlan0" + , "domain=kitenet.net" + , "dhcp-range=10.1.1.100,10.1.1.150,24h" + , "no-hosts" + , "address=/honeybee.kitenet.net/10.1.1.1" + ] + `onChange` Service.restarted "dnsmasq" & ipmasq "wlan0" & Apt.serviceInstalledRunning "netplug" & Network.dhcp' "eth0" diff --git a/src/Propellor/Property/Uboot.hs b/src/Propellor/Property/Uboot.hs @@ -0,0 +1,36 @@ +module Propellor.Property.Uboot where + +import Propellor.Base +import Propellor.Types.Info +import Propellor.Types.Bootloader +import Propellor.Property.Chroot +import Propellor.Property.Mount +import qualified Propellor.Property.Apt as Apt + +-- | Name of a board. +type BoardName = String + +-- | Installs u-boot for Allwinner/sunxi platforms. +-- +-- This includes writing it to the boot sector. +sunxi :: BoardName -> Property (HasInfo + DebianLike) +sunxi boardname = setInfoProperty (check (not <$> inChroot) go) info + `requires` Apt.installed ["u-boot", "u-boot-sunxi"] + where + go :: Property Linux + go = property' "u-boot installed" $ \w -> do + v <- liftIO $ getMountContaining "/boot" + case v of + Nothing -> error "unable to determine boot device" + Just dev -> ensureProperty w (dd dev "/") + dd :: FilePath -> FilePath -> Property Linux + dd dev prefix = tightenTargets $ cmdProperty "dd" + [ "conv=fsync,notrunc" + , "if=" ++ prefix ++ "/usr/lib/u-boot/" + ++ boardname ++ "/u-boot-sunxi-with-spl.bin" + , "of=" ++ dev + , "bs=1024" + , "seek=8" + ] + `assume` NoChange + info = toInfo [UbootInstalled dd] diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs @@ -2,11 +2,20 @@ module Propellor.Types.Bootloader where +import Propellor.Types import Propellor.Types.Info -- | Boot loader installed on a host. -data BootloaderInstalled = GrubInstalled - deriving (Typeable, Show) +data BootloaderInstalled + = GrubInstalled + | FlashKernelInstalled + | UbootInstalled (FilePath -> FilePath -> Property Linux) + deriving (Typeable) + +instance Show BootloaderInstalled where + show GrubInstalled = "GrubInstalled" + show FlashKernelInstalled = "FlashKernelInstalled" + show (UbootInstalled _) = "UbootInstalled" instance IsInfo [BootloaderInstalled] where propagateInfo _ = PropagateInfo False diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs @@ -1,66 +1,14 @@ --- | Partition specification combinators. - module Propellor.Types.PartSpec where -import Propellor.Base import Propellor.Property.Parted.Types import Propellor.Property.Mount -import Propellor.Property.Partition -- | Specifies a mount point, mount options, and a constructor for a -- Partition that determines its size. type PartSpec t = (Maybe MountPoint, MountOpts, PartSize -> Partition, t) --- | Specifies a partition with a given filesystem. --- --- The partition is not mounted anywhere by default; use the combinators --- below to configure it. -partition :: Monoid t => Fs -> PartSpec t -partition fs = (Nothing, mempty, mkPartition fs, mempty) - --- | Specifies a swap partition of a given size. -swapPartition :: Monoid t => PartSize -> PartSpec t -swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty) - --- | Specifies where to mount a partition. -mountedAt :: PartSpec t -> FilePath -> PartSpec t -mountedAt (_, o, p, t) mp = (Just mp, o, p, t) - --- | Specify a fixed size for a partition. -setSize :: PartSpec t -> PartSize -> PartSpec t -setSize (mp, o, p, t) sz = (mp, o, const (p sz), t) - --- | Specifies a mount option, such as "noexec" -mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t -mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t) - --- | Mount option to make a partition be remounted readonly when there's an --- error accessing it. -errorReadonly :: MountOpts -errorReadonly = toMountOpts "errors=remount-ro" - --- | Sets the percent of the filesystem blocks reserved for the super-user. --- --- The default is 5% for ext2 and ext4. Some filesystems may not support --- this. -reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t -reservedSpacePercentage s percent = adjustp s $ \p -> - p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p } - --- | Sets a flag on the partition. -setFlag :: PartSpec t -> PartFlag -> PartSpec t -setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } - --- | Makes a MSDOS partition be Extended, rather than Primary. -extended :: PartSpec t -> PartSpec t -extended s = adjustp s $ \p -> p { partType = Extended } - -adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t -adjustp (mp, o, p, t) f = (mp, o, f . p, t) - -adjustt :: PartSpec t -> (t -> t) -> PartSpec t -adjustt (mp, o, p, t) f = (mp, o, p, f t) +-- | Specifies a partition table. +data PartTableSpec = PartTableSpec TableType [PartSpec ()] --- | Default partition size when not otherwize specified is 128 MegaBytes. -defSz :: PartSize -defSz = MegaBytes 128 +instance Show PartTableSpec where + show (PartTableSpec tt _) = "PartTableSpec " ++ show tt