propellor

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

commit 084d5b12f18a08623501e13794dcbf8f7b32ffe2
parent d8b005a4face4597ace49c9d12d76b555169020b
Author: rsiddharth <s@ricketyspace.net>
Date:   Sat,  6 Jan 2018 05:54:14 +0000

Merge remote-tracking branch 'upstream/master'

Diffstat:
debian/changelog | 34++++++++++++++++++++++++++++++++++
joeyconfig.hs | 22++++++++--------------
propellor.cabal | 5++++-
src/Propellor/Property/Bootstrap.hs | 14+++++++++++++-
src/Propellor/Property/DiskImage.hs | 52+++++++++++++++++++++++++++++++++-------------------
src/Propellor/Property/DiskImage/PartSpec.hs | 6+++---
src/Propellor/Property/Grub.hs | 62++++++++++++++++++++++++++++++++++++++++++--------------------
src/Propellor/Property/Installer.hs | 20++++++++++++++++++++
src/Propellor/Property/Installer/Target.hs | 462+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Installer/Types.hs | 16++++++++++++++++
src/Propellor/Property/Mount.hs | 4+++-
src/Propellor/Property/Parted.hs | 93+++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------------------
src/Propellor/Property/Parted/Types.hs | 61+++++++++++++++++++++++++++++++++++++++++--------------------
src/Propellor/Property/Sbuild.hs | 15+++++++++++++++
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 2++
src/Propellor/Property/SiteSpecific/JoeySites.hs | 51++++++++++++++++++++++++++++++++++++++++++++++++---
src/Propellor/Types/Bootloader.hs | 7+++++--
17 files changed, 816 insertions(+), 110 deletions(-)

diff --git a/debian/changelog b/debian/changelog @@ -1,3 +1,37 @@ +propellor (5.2.0-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Tue, 02 Jan 2018 11:06:08 +0000 + +propellor (5.2.0) unstable; urgency=medium + + [ Joey Hess ] + * bootstrappedFrom: Set up local privdata file. + * Parted: Fix names used for FAT and VFAT partitions. + * Parted: Add an Alignment parameter. (API change) + A good default to use is safeAlignment, which is 4MiB, + well suited for inexpensive flash drives, and fine for other disks too. + Previously, a very non-optimial 1MB (not 1MiB) alignment had been used. + * DiskImage: Use safeAlignment. It didn't seem worth making the + alignment configurable here. + * Fixed rounding bug in Parted.calcPartTable. + * DiskImage: Fix rsync crash when a mount point does not exist in the + chroot. + * Fix bug in unmountBelow that caused unmounting of nested mounts to + fail. + * Grub.boots, Grub.bootsMounted: Pass --target to grub-install. + * Added Propellor.Property.Installer modules, which can be used to create + bootable installer disk images, which then run propellor to install + a system. This code was extracted from the demo I gave in my + talk at DebConf 2017. + + [ Sean Whitton ] + * Sbuild: add notes about Debian jessie hosts and backports of sbuild and + autopkgtest. + + -- Joey Hess <id@joeyh.name> Sat, 30 Dec 2017 13:34:29 -0400 + propellor (5.1.0-1) unstable; urgency=medium * Package new upstream release. diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -32,7 +32,6 @@ import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald import qualified Propellor.Property.Fail2Ban as Fail2Ban -import qualified Propellor.Property.Aiccu as Aiccu import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode @@ -86,20 +85,20 @@ darkstar :: Host darkstar = host "darkstar.kitenet.net" $ props & osDebian Unstable X86_64 & ipv6 "2001:4830:1600:187::2" - & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" - - & User.nuked (User "nosuchuser") User.YesReallyDeleteHome + & Hostname.sane + & Apt.serviceInstalledRunning "swapspace" & JoeySites.dkimMilter & JoeySites.postfixSaslPasswordClient -- & JoeySites.alarmClock "*-*-* 7:30" (User "joey") -- "/usr/bin/timeout 45m /home/joey/bin/goodmorning" + & JoeySites.laptopSoftware & Ssh.userKeys (User "joey") hostContext [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - & imageBuiltFor honeybee - (RawDiskImage "/srv/honeybee.img") - (Debootstrapped mempty) + -- & imageBuiltFor honeybee + -- (RawDiskImage "/srv/honeybee.img") + -- (Debootstrapped mempty) gnu :: Host gnu = host "gnu.kitenet.net" $ props @@ -183,15 +182,9 @@ honeybee = host "honeybee.kitenet.net" $ props & cubietech_Cubietruck & hasPartition - ( partition EXT2 - `mountedAt` "/boot" - `partLocation` Beginning - `setSize` MegaBytes 200 - ) - & hasPartition ( partition EXT4 `mountedAt` "/" - `addFreeSpace` MegaBytes 500 + `setSize` MegaBytes 8000 ) & Apt.installed ["firmware-brcm80211"] @@ -207,6 +200,7 @@ honeybee = host "honeybee.kitenet.net" $ props & JoeySites.homePowerMonitor (User "joey") + hosts (Context "homepower.joeyh.name") (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIMAmVYddg/RgCbIj+cLcEiddeFXaYFnbEJ3uGj9G/EyV joey@honeybee") & JoeySites.homeRouter diff --git a/propellor.cabal b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 5.1.0 +Version: 5.2.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> @@ -121,6 +121,9 @@ Library Propellor.Property.Gpg Propellor.Property.Group Propellor.Property.Grub + Propellor.Property.Installer + Propellor.Property.Installer.Types + Propellor.Property.Installer.Target Propellor.Property.Journald Propellor.Property.Kerberos Propellor.Property.LetsEncrypt diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs @@ -14,6 +14,8 @@ import Propellor.Base import Propellor.Bootstrap import Propellor.Types.Info import Propellor.Property.Chroot +import Propellor.PrivData.Paths +import Utility.FileMode import Data.List import qualified Data.ByteString as B @@ -63,8 +65,18 @@ bootstrappedFrom reposource = check inChroot $ go :: Property Linux go = property "Propellor bootstrapped" $ do system <- getOS + -- gets Host value representing the chroot this is run in + chroothost <- ask + -- load privdata from outside the chroot, and filter + -- to only the privdata needed inside the chroot. + privdata <- liftIO $ filterPrivData chroothost + <$> readPrivDataFile privDataLocal bootstrapper <- getBootstrapper - assumeChange $ exposeTrueLocaldir $ const $ + assumeChange $ exposeTrueLocaldir $ const $ do + liftIO $ createDirectoryIfMissing True $ + takeDirectory privDataLocal + liftIO $ writeFileProtected privDataLocal $ + show privdata runShellCommand $ buildShellCommand [ "cd " ++ localdir , checkDepsCommand bootstrapper system diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs @@ -17,7 +17,7 @@ module Propellor.Property.DiskImage ( imageRebuiltFor, imageBuiltFrom, imageExists, - Grub.BIOS(..), + GrubTarget(..), ) where import Propellor.Base @@ -41,6 +41,7 @@ import Propellor.Types.Bootloader import Propellor.Container import Utility.Path import Utility.FileMode +import Utility.DataUnits import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4) import Data.Function (on) @@ -220,7 +221,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec = -- installed. final = case fromInfo (containerInfo chroot) of [] -> unbootable "no bootloader is installed" - [GrubInstalled] -> grubFinalized + [GrubInstalled grubtarget] -> grubFinalized grubtarget [UbootInstalled p] -> ubootFinalized p [FlashKernelInstalled] -> flashKernelFinalized [UbootInstalled p, FlashKernelInstalled] -> @@ -265,7 +266,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg imageFinalized final dest mnts mntopts devs parttable rmimg = undoRevertableProperty (buildDiskImage img) `before` undoRevertableProperty (imageExists' dest dummyparttable) - dummyparttable = PartTable tabletype [] + dummyparttable = PartTable tabletype safeAlignment [] partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> @@ -274,13 +275,18 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> desc = "partitions populated from " ++ chrootdir go _ Nothing _ _ = noChange - go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket - (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) - (const $ liftIO $ umountLazy tmpdir) - $ \ismounted -> if ismounted - then ensureProperty w $ - syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir - else return FailedChange + go w (Just mnt) mntopt loopdev = ifM (liftIO $ doesDirectoryExist srcdir) $ + ( withTmpDir "mnt" $ \tmpdir -> bracket + (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) + (const $ liftIO $ umountLazy tmpdir) + $ \ismounted -> if ismounted + then ensureProperty w $ + syncDirFiltered (filtersfor mnt) srcdir tmpdir + else return FailedChange + , return NoChange + ) + where + srcdir = chrootdir ++ mnt filtersfor mnt = let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $ @@ -300,7 +306,7 @@ fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint] fitChrootSize tt l basesizes = (mounts, mountopts, parttable) where (mounts, mountopts, sizers, _) = unzip4 l - parttable = PartTable tt (zipWith id sizers basesizes) + parttable = PartTable tt safeAlignment (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of -- every directory in a filesystem tree. @@ -339,17 +345,24 @@ getMountSz szm l (Just mntpt) = imageExists :: RawDiskImage -> ByteSize -> Property Linux imageExists (RawDiskImage img) isz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img - case ms of + case fmap (toInteger . fileSize) ms of Just s - | toInteger (fileSize s) == toInteger sz -> return NoChange - | toInteger (fileSize s) > toInteger sz -> do + | s == toInteger sz -> return NoChange + | s > toInteger sz -> do + infoMessage ["truncating " ++ img ++ " to " ++ humansz] setFileSize img (fromInteger sz) return MadeChange - _ -> do + | otherwise -> do + infoMessage ["expanding " ++ img ++ " from " ++ roughSize storageUnits False s ++ " to " ++ humansz] + L.writeFile img (L.replicate (fromIntegral sz) 0) + return MadeChange + Nothing -> do + infoMessage ["creating " ++ img ++ " of size " ++ humansz] L.writeFile img (L.replicate (fromIntegral sz) 0) return MadeChange where sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize + humansz = roughSize storageUnits False (toInteger sz) -- Disks have a sector size, and making a disk image not -- aligned to a sector size will confuse some programs. -- Common sector sizes are 512 and 4096; use 4096 as it's larger. @@ -388,7 +401,7 @@ imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux) imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux -imageFinalized final img mnts mntopts devs (PartTable _ parts) = +imageFinalized final img mnts mntopts devs (PartTable _ _ parts) = property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> go w top `finally` liftIO (unmountall top) @@ -441,9 +454,10 @@ unbootable msg = \_ _ _ -> property desc $ do where desc = "image is not bootable" -grubFinalized :: Finalization -grubFinalized _img mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev - `describe` "disk image boots using grub" +grubFinalized :: GrubTarget -> Finalization +grubFinalized grubtarget _img mnt loopdevs = + Grub.bootsMounted mnt wholediskloopdev grubtarget + `describe` "disk image boots using grub" where -- It doesn't matter which loopdev we use; all -- come from the same disk image, and it's the loop dev diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -160,8 +160,8 @@ hasPartition p@(mmp, _, _, _) = pureInfoProperty desc (PartInfo [PartSpecInfo p]) where desc = case mmp of - Just mp -> "has " ++ mp ++ " partition" - Nothing -> "has unmounted partition" + Just mp -> mp ++ " partition" + Nothing -> "unmounted partition" -- | Adjusts the PartSpec for the partition mounted at the specified location. -- @@ -170,7 +170,7 @@ hasPartition p@(mmp, _, _, _) = pureInfoProperty desc -- > & adjustPartition "/boot" (`addFreeSpace` MegaBytes 150) adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike) adjustPartition mp f = pureInfoProperty - ("has " ++ mp ++ " adjusted") + (mp ++ " adjusted") (PartInfo [AdjustPartSpecInfo mp f]) -- | Indicates partition layout in a disk. Default is somewhere in the diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs @@ -1,4 +1,15 @@ -module Propellor.Property.Grub where +module Propellor.Property.Grub ( + GrubDevice, + OSDevice, + GrubTarget(..), + installed, + mkConfig, + installed', + boots, + bootsMounted, + TimeoutSecs, + chainPVGrub +) where import Propellor.Base import qualified Propellor.Property.File as File @@ -14,40 +25,36 @@ type GrubDevice = String -- | Eg, \"\/dev/sda\" type OSDevice = String -type TimeoutSecs = Int - --- | Types of machines that grub can boot. -data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen - -- | Installs the grub package. This does not make grub be used as the -- bootloader. -- -- This includes running update-grub, unless it's run in a chroot. -installed :: BIOS -> Property (HasInfo + DebianLike) -installed bios = installed' bios +installed :: GrubTarget -> Property (HasInfo + DebianLike) +installed grubtarget = installed' grubtarget `onChange` (check (not <$> inChroot) mkConfig) --- Run update-grub, to generate the grub boot menu. It will be +-- | Run update-grub, to generate the grub boot menu. It will be -- automatically updated when kernel packages are installed. mkConfig :: Property DebianLike mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property (HasInfo + DebianLike) -installed' bios = setInfoProperty aptinstall - (toInfo [GrubInstalled]) +installed' :: GrubTarget -> Property (HasInfo + DebianLike) +installed' grubtarget = setInfoProperty aptinstall + (toInfo [GrubInstalled grubtarget]) `describe` "grub package installed" where aptinstall = Apt.installed [debpkg] - debpkg = case bios of + debpkg = case grubtarget of PC -> "grub-pc" EFI64 -> "grub-efi-amd64" EFI32 -> "grub-efi-ia32" Coreboot -> "grub-coreboot" Xen -> "grub-xen" --- | Installs grub onto a device, so the system can boot from that device. +-- | Installs grub onto a device's boot loader, +-- so the system can boot from that device. -- -- You may want to install grub to multiple devices; eg for a system -- that uses software RAID. @@ -57,9 +64,24 @@ installed' bios = setInfoProperty aptinstall -- to arrange for this property to only run once, by eg making it be run -- onChange after OS.cleanInstallOnce. boots :: OSDevice -> Property Linux -boots dev = tightenTargets $ cmdProperty "grub-install" [dev] - `assume` MadeChange - `describe` ("grub boots " ++ dev) +boots dev = property' ("grub boots " ++ dev) $ \w -> do + grubtarget <- askInfo + let ps = case grubtarget of + [GrubInstalled t] -> [targetParam t] + _ -> [] + ensureProperty w $ + cmdProperty "grub-install" (ps ++ [dev]) + `assume` MadeChange + +targetParam :: GrubTarget -> String +targetParam t = "--target=" ++ case t of + PC -> "i386-pc" + EFI32 -> "i386-efi" + EFI64 -> "x86_64-efi" + Coreboot -> "i386-coreboot" + Xen -> "x86_64-xen" + +type TimeoutSecs = Int -- | Use PV-grub chaining to boot -- @@ -95,8 +117,8 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc $ props -- at a particular directory. The OSDevice should be the underlying disk -- device that grub will be installed to (generally a whole disk, -- not a partition). -bootsMounted :: FilePath -> OSDevice -> Property Linux -bootsMounted mnt wholediskdev = combineProperties desc $ props +bootsMounted :: FilePath -> OSDevice -> GrubTarget -> Property Linux +bootsMounted mnt wholediskdev grubtarget = combineProperties desc $ props -- remove mounts that are done below to make sure the right thing -- gets mounted & cleanupmounts @@ -112,7 +134,7 @@ bootsMounted mnt wholediskdev = combineProperties desc $ props & inchroot "update-grub" [] `assume` MadeChange & check haveosprober (inchroot "chmod" ["+x", osprober]) - & inchroot "grub-install" [wholediskdev] + & inchroot "grub-install" [targetParam grubtarget, wholediskdev] `assume` MadeChange & cleanupmounts -- sync all buffered changes out to the disk in case it's diff --git a/src/Propellor/Property/Installer.hs b/src/Propellor/Property/Installer.hs @@ -0,0 +1,20 @@ +-- | Installer disk image generation +-- +-- These modules contain properties that can be used to create a disk +-- image, suitable for booting from removable media, that can perform an +-- interactive or non-interactive installation of a Host's internal disk. +-- +-- The disk image is created using propellor. When booted, it runs +-- propellor to install to the desired disk. +-- +-- There is no user interface included here. For an example of using +-- this to build a full, interactive installer, see +-- <https://git.joeyh.name/index.cgi/secret-project.git/> + +module Propellor.Property.Installer ( + module Propellor.Property.Installer.Types, + module Propellor.Property.Installer.Target +) where + +import Propellor.Property.Installer.Types +import Propellor.Property.Installer.Target diff --git a/src/Propellor/Property/Installer/Target.hs b/src/Propellor/Property/Installer/Target.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE TypeOperators #-} + +-- | Installation to a target disk. +-- +-- Note that the RevertableProperties in this module are not really +-- revertable; the target disk can't be put back how it was. +-- The RevertableProperty type is used only to let them be used +-- in a Versioned Host as shown below. +-- +-- Here's an example of a noninteractive installer image using +-- these properties. +-- +-- There are two versions of Hosts, the installer and the target system. +-- +-- > data Variety = Installer | Target +-- > deriving (Eq) +-- +-- The seed of both the installer and the target. They have some properties +-- in common, and some different properties. The `targetInstalled` +-- property knows how to convert the installer it's running on into a +-- target system. +-- +-- > seed :: Versioned Variety Host +-- > seed ver = host "debian.local" $ props +-- > & osDebian Unstable X86_64 +-- > & Hostname.sane +-- > & Apt.stdSourcesList +-- > & Apt.installed ["linux-image-amd64"] +-- > & Grub.installed PC +-- > & "en_US.UTF-8" `Locale.selectedFor` ["LANG"] +-- > & ver ( (== Installer) --> targetInstalled seed Target (userInput ver) parts) +-- > & ver ( (== Target) --> fstabLists (userInput ver) parts) +-- > & ver ( (== Installer) --> targetBootable (userInput ver)) +-- > where +-- > parts = TargetPartTable MSDOS +-- > [ partition EXT4 `mountedAt` "/" +-- > `useDiskSpace` RemainingSpace +-- > , swapPartition (MegaBytes 1024) +-- > ] +-- +-- The installer disk image can then be built from the seed as follows: +-- +-- > installerBuilt :: RevertableProperty (HasInfo + DebianLike) Linux +-- > installerBuilt = imageBuilt (VirtualBoxPointer "/srv/installer.vmdk") +-- > (hostChroot (seed `version` installer) (Debootstrapped mempty)) +-- > MSDOS +-- > [ partition EXT4 `mountedAt` "/" +-- > `setFlag` BootFlag +-- > `reservedSpacePercentage` 0 +-- > `addFreeSpace` MegaBytes 256 +-- > ] +-- +-- When the installer is booted up, and propellor is run, it installs +-- to the target disk. Since this example is a noninteractive installer, +-- the details of what it installs to are configured before it's built. +-- +-- > data HardCodedUserInput = HardCodedUserInput (Maybe TargetDiskDevice) (Maybe DiskEraseConfirmed) +-- > +-- > instance UserInput HardCodedUserInput where +-- > targetDiskDevice (HardCodedUserInput t _) = Just t +-- > diskEraseConfirmed (HardCodedUserInput _ c) = Just c +-- > +-- > userInput :: Version -> HardCodedUserInput +-- > userInput Installer = HardCodedUserInput Nothing Nothing +-- > userInput Target = HardCodedUserInput (Just (TargetDiskDevice "/dev/sda")) (Just DiskEraseConfirmed) +-- +-- For an example of how to use this to make an interactive installer, +-- see <https://git.joeyh.name/index.cgi/secret-project.git/> + +module Propellor.Property.Installer.Target ( + TargetPartTable(..), + targetInstalled, + mountTarget, + fstabLists, + targetBootable, + partitionTargetDisk, + targetDir, + probeDisk, + findDiskDevices, + TargetFilled, + TargetFilledHandle, + prepTargetFilled, + checkTargetFilled, + TargetFilledPercent(..), + targetFilledPercent, +) where + +import Propellor +import Propellor.Property.Installer.Types +import Propellor.Message +import Propellor.Types.Bootloader +import Propellor.Types.PartSpec +import Propellor.Property.Chroot +import Propellor.Property.Versioned +import Propellor.Property.Parted +import Propellor.Property.Mount +import qualified Propellor.Property.Fstab as Fstab +import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.Rsync as Rsync + +import Text.Read +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import System.Directory +import System.FilePath +import Data.Maybe +import Data.List +import Data.Char +import Data.Ord +import Data.Ratio +import System.Process (readProcess) + +data TargetPartTable = TargetPartTable TableType [PartSpec DiskPart] + +-- | Property that installs the target system to the TargetDiskDevice +-- specified in the UserInput. That device will be re-partitioned and +-- formatted and all files erased. +-- +-- The installation is done efficiently by rsyncing the installer's files +-- to the target, which forms the basis for a chroot that is provisioned with +-- the specified version of the Host. Thanks to +-- Propellor.Property.Versioned, any unwanted properties of the installer +-- will be automatically reverted in the chroot. +-- +-- When there is no TargetDiskDevice or the user has not confirmed the +-- installation, nothing is done except for installing dependencies. +-- So, this can also be used as a property of the installer +-- image. +targetInstalled + :: UserInput i + => Versioned v Host + -> v + -> i + -> TargetPartTable + -> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike) +targetInstalled vtargethost v userinput (TargetPartTable tabletype partspec) = + case (targetDiskDevice userinput, diskEraseConfirmed userinput) of + (Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> + go `describe` ("target system installed to " ++ targetdev) + _ -> tightenTargets installdeps <!> doNothing + where + targethost = vtargethost `version` v + go = RevertableProperty + (setupRevertableProperty p) + -- Versioned needs both "sides" of the RevertableProperty + -- to have the same type, so add empty Info to make the + -- types line up. + (undoRevertableProperty p `setInfoProperty` mempty) + where + p = partitionTargetDisk userinput tabletype partspec + `before` mountTarget userinput partspec + `before` provisioned chroot + + chroot = hostChroot targethost RsyncBootstrapper targetDir + + -- Install dependencies that will be needed later when installing + -- the target. + installdeps = Rsync.installed + +data RsyncBootstrapper = RsyncBootstrapper + +instance ChrootBootstrapper RsyncBootstrapper where + buildchroot RsyncBootstrapper _ target = Right $ + mountaside + `before` rsynced + `before` umountaside + where + -- bind mount the root filesystem to /mnt, which exposes + -- the contents of all directories that have things mounted + -- on top of them to rsync. + mountaside = bindMount "/" "/mnt" + rsynced = Rsync.rsync + [ "--one-file-system" + , "-aHAXS" + , "--delete" + , "/mnt/" + , target + ] + umountaside = cmdProperty "umount" ["-l", "/mnt"] + `assume` MadeChange + +mountTarget + :: UserInput i + => i + -> [PartSpec DiskPart] + -> RevertableProperty Linux Linux +mountTarget userinput partspec = setup <!> cleanup + where + setup = property "target mounted" $ + case targetDiskDevice userinput of + Just (TargetDiskDevice targetdev) -> do + liftIO unmountTarget + r <- liftIO $ forM tomount $ + mountone targetdev + if and r + then return MadeChange + else return FailedChange + Nothing -> return NoChange + cleanup = property "target unmounted" $ do + liftIO unmountTarget + liftIO $ removeDirectoryRecursive targetDir + return NoChange + + -- Sort so / comes before /home etc + tomount = sortOn (fst . fst) $ + map (\((mp, mo, _, _), n) -> ((mp, mo), n)) $ + zip partspec partNums + + mountone targetdev ((mmountpoint, mountopts), num) = + case mmountpoint of + Nothing -> return True + Just mountpoint -> do + let targetmount = targetDir ++ mountpoint + createDirectoryIfMissing True targetmount + let dev = diskPartition targetdev num + mount "auto" dev targetmount mountopts + +-- | Property for use in the target Host to set up its fstab. +-- Should be passed the same TargetPartTable as `targetInstalled`. +fstabLists + :: UserInput i + => i + -> TargetPartTable + -> RevertableProperty Linux Linux +fstabLists userinput (TargetPartTable _ partspecs) = setup <!> doNothing + where + setup = case targetDiskDevice userinput of + Just (TargetDiskDevice targetdev) -> + Fstab.fstabbed mnts (swaps targetdev) + `requires` devmounted + `before` devumounted + Nothing -> doNothing + + -- needed for ftabbed UUID probing to work + devmounted :: Property Linux + devmounted = tightenTargets $ mounted "devtmpfs" "udev" "/dev" mempty + devumounted :: Property Linux + devumounted = tightenTargets $ cmdProperty "umount" ["-l", "/dev"] + `assume` MadeChange + + partitions = map (\(mp, _, mkpart, _) -> (mp, mkpart mempty)) partspecs + mnts = mapMaybe fst $ + filter (\(_, p) -> partFs p /= LinuxSwap) partitions + swaps targetdev = + map (Fstab.SwapPartition . diskPartition targetdev . snd) $ + filter (\((_, p), _) -> partFs p == LinuxSwap) + (zip partitions partNums) + +-- | Make the target bootable using whatever bootloader is installed on it. +targetBootable + :: UserInput i + => i + -> RevertableProperty Linux Linux +targetBootable userinput = + case (targetDiskDevice userinput, diskEraseConfirmed userinput) of + (Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> + go targetdev <!> doNothing + _ -> doNothing <!> doNothing + where + desc = "bootloader installed on target disk" + go :: FilePath -> Property Linux + go targetdev = property' desc $ \w -> do + bootloaders <- askInfo + case bootloaders of + [GrubInstalled gt] -> ensureProperty w $ + Grub.bootsMounted targetDir targetdev gt + [] -> do + warningMessage "no bootloader was installed" + return NoChange + l -> do + warningMessage $ "don't know how to enable bootloader(s) " ++ show l + return FailedChange + +partitionTargetDisk + :: UserInput i + => i + -> TableType + -> [PartSpec DiskPart] + -> RevertableProperty DebianLike DebianLike +partitionTargetDisk userinput tabletype partspec = go <!> doNothing + where + go = check targetNotMounted $ property' "target disk partitioned" $ \w -> do + case (targetDiskDevice userinput, diskEraseConfirmed userinput) of + (Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> do + liftIO $ unmountTarget + disksize <- liftIO $ getDiskSize targetdev + let parttable = calcPartTable disksize tabletype safeAlignment partspec + ensureProperty w $ + partitioned YesReallyDeleteDiskContents targetdev parttable + _ -> error "user input does not allow partitioning disk" + +unmountTarget :: IO () +unmountTarget = mapM_ umountLazy . reverse . sort =<< targetMountPoints + +targetMountPoints :: IO [MountPoint] +targetMountPoints = filter isTargetMountPoint <$> mountPoints + +isTargetMountPoint :: MountPoint -> Bool +isTargetMountPoint mp = + mp == targetDir + || addTrailingPathSeparator targetDir `isPrefixOf` mp + +targetNotMounted :: IO Bool +targetNotMounted = not . any (== targetDir) <$> mountPoints + +-- | Where the target disk is mounted while it's being installed. +targetDir :: FilePath +targetDir = "/target" + +partNums :: [Integer] +partNums = [1..] + +-- /dev/sda to /dev/sda1 +diskPartition :: FilePath -> Integer -> FilePath +diskPartition dev num = dev ++ show num + +-- | This can be used to find a likely disk device to use as the target +-- for an installation. +-- +-- This is a bit of a hack; of course the user could be prompted but to +-- avoid prompting, some heuristics... +-- * It should not already be mounted. +-- * Prefer disks big enough to comfortably hold a Linux installation, +-- so at least 8 gb. +-- (But, if the system only has a smaller disk, it should be used.) +-- * A medium size internal disk is better than a large removable disk, +-- because removable or added drives are often used for data storage +-- on systems with smaller internal disk for the OS. +-- (But, if the internal disk is too small, prefer removable disk; +-- some systems have an unusably small internal disk.) +-- * Prefer the first disk in BIOS order, all other things being equal, +-- because the main OS disk typically comes first. This can be +-- approximated by preferring /dev/sda to /dev/sdb. +probeDisk :: IO TargetDiskDevice +probeDisk = do + unmountTarget + mounteddevs <- getMountedDeviceIDs + let notmounted d = flip notElem (map Just mounteddevs) + <$> getMinorNumber d + candidates <- mapM probeCandidate + =<< filterM notmounted + =<< findDiskDevices + case reverse (sort candidates) of + (Candidate { candidateDevice = Down dev } : _) -> + return $ TargetDiskDevice dev + [] -> error "Unable to find any disk to install to!" + +-- | Find disk devices, such as /dev/sda (not partitions) +findDiskDevices :: IO [FilePath] +findDiskDevices = map ("/dev" </>) . filter isdisk + <$> getDirectoryContents "/dev" + where + isdisk ('s':'d':_:[]) = True + isdisk _ = False + +-- | When comparing two Candidates, the better of the two will be larger. +data Candidate = Candidate + { candidateBigEnoughForOS :: Bool + , candidateIsFixedDisk :: Bool + -- use Down so that /dev/sda orders larger than /dev/sdb + , candidateDevice :: Down FilePath + } deriving (Eq, Ord) + +probeCandidate :: FilePath -> IO Candidate +probeCandidate dev = do + DiskSize sz <- getDiskSize dev + isfixeddisk <- not <$> isRemovableDisk dev + return $ Candidate + { candidateBigEnoughForOS = sz >= 8 * onegb + , candidateIsFixedDisk = isfixeddisk + , candidateDevice = Down dev + } + where + onegb = 1024*1024*1000 + +newtype MinorNumber = MinorNumber Integer + deriving (Eq, Show) + +getMountedDeviceIDs :: IO [MinorNumber] +getMountedDeviceIDs = mapMaybe parse . lines <$> readProcess "findmnt" + [ "-rn" + , "--output" + , "MAJ:MIN" + ] + "" + where + parse = fmap MinorNumber . readMaybe + . dropWhile (not . isDigit) . dropWhile (/= ':') + +-- There is not currently a native haskell interface for getting the minor +-- number of a device. +getMinorNumber :: FilePath -> IO (Maybe MinorNumber) +getMinorNumber dev = fmap MinorNumber . readMaybe + <$> readProcess "stat" [ "--printf", "%T", dev ] "" + +-- A removable disk may show up as removable or as hotplug. +isRemovableDisk :: FilePath -> IO Bool +isRemovableDisk dev = do + isremovable <- checkblk "RM" + ishotplug <- checkblk "HOTPLUG" + return (isremovable || ishotplug) + where + checkblk field = (== "1\n") <$> readProcess "lsblk" + [ "-rn" + , "--nodeps" + , "--output", field + , dev + ] + "" + +getDiskSize :: FilePath -> IO DiskSize +getDiskSize dev = do + sectors <- fromMaybe 0 . readMaybe + <$> readProcess "blockdev" ["--getsz", dev] "" + return (DiskSize (sectors * 512)) + +getMountsSizes :: IO [(MountPoint, Integer)] +getMountsSizes = mapMaybe (parse . words) . lines <$> readProcess "findmnt" ps "" + where + ps = ["-rnb", "-o", "TARGET,USED"] + parse (mp:szs:[]) = do + sz <- readMaybe szs + return (mp, sz) + parse _ = Nothing + +-- | How much of the target disks are used, compared with the size of the +-- installer's root device. Since the main part of an installation +-- is rsyncing the latter to the former, this allows roughly estimating +-- the percent done while an install is running, and can be used in some +-- sort of progress display. +data TargetFilled = TargetFilled (Ratio Integer) + deriving (Show, Eq) + +instance Monoid TargetFilled where + mempty = TargetFilled (0 % 1) + mappend (TargetFilled n) (TargetFilled m) = TargetFilled (n+m) + +newtype TargetFilledHandle = TargetFilledHandle Integer + +prepTargetFilled :: IO TargetFilledHandle +prepTargetFilled = go =<< getMountSource "/" + where + go (Just dev) = do + -- Assumes that the installer uses a single partition. + DiskSize sz <- getDiskSize dev + return (TargetFilledHandle sz) + go Nothing = return (TargetFilledHandle 0) + +checkTargetFilled :: TargetFilledHandle -> IO TargetFilled +checkTargetFilled (TargetFilledHandle installsz) = do + targetsz <- sum . map snd . filter (isTargetMountPoint . fst) + <$> getMountsSizes + return (TargetFilled (targetsz % max 1 installsz)) + +newtype TargetFilledPercent = TargetFilledPercent Int + deriving (Show, Eq) + +targetFilledPercent :: TargetFilled -> TargetFilledPercent +targetFilledPercent (TargetFilled r) = TargetFilledPercent $ floor percent + where + percent :: Double + percent = min 100 (fromRational r * 100) diff --git a/src/Propellor/Property/Installer/Types.hs b/src/Propellor/Property/Installer/Types.hs @@ -0,0 +1,16 @@ +module Propellor.Property.Installer.Types where + +-- | The disk device to install to. +newtype TargetDiskDevice = TargetDiskDevice FilePath + deriving (Read, Show) + +data DiskEraseConfirmed = DiskEraseConfirmed + deriving (Read, Show) + +-- | Class of user input that an installer might prompt for. +class UserInput i where + -- | Get the disk device the user selected to install to. + targetDiskDevice :: i -> Maybe TargetDiskDevice + -- | Check if the user has confirmed they want to erase the target + -- disk device. + diskEraseConfirmed :: i -> Maybe DiskEraseConfirmed diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs @@ -149,4 +149,6 @@ umountLazy mnt = unmountBelow :: FilePath -> IO () unmountBelow d = do submnts <- mountPointsBelow d - forM_ submnts umountLazy + -- sort so sub-mounts are unmounted before the mount point + -- containing them + forM_ (reverse (sort submnts)) umountLazy diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs @@ -13,6 +13,8 @@ module Propellor.Property.Parted ( toPartSize, fromPartSize, reducePartSize, + Alignment(..), + safeAlignment, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -50,19 +52,28 @@ data Eep = YesReallyDeleteDiskContents -- -- This deletes any existing partitions in the disk! Use with EXTREME caution! partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike -partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do +partitioned eep disk parttable@(PartTable _ _ parts) = property' desc $ \w -> do isdev <- liftIO $ isBlockDevice <$> getFileStatus disk ensureProperty w $ combineProperties desc $ props - & parted eep disk partedparams + & parted eep disk (fst (calcPartedParamsSize parttable)) & if isdev then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) else Partition.kpartx disk (formatl . map Partition.partitionLoopDev) where desc = disk ++ " partitioned" formatl devs = combineProperties desc (toProps $ map format (zip parts devs)) - partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev + +-- | Gets the total size of the disk specified by the partition table. +partTableSize :: PartTable -> ByteSize +partTableSize = snd . calcPartedParamsSize + +calcPartedParamsSize :: PartTable -> ([String], ByteSize) +calcPartedParamsSize (PartTable tabletype alignment parts) = + let (ps, sz) = calcparts (1 :: Integer) firstpos parts [] + in (concat (mklabel : ps), sz) + where mklabel = ["mklabel", pval tabletype] mkflag partnum (f, b) = [ "set" @@ -70,39 +81,58 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do , pval f , pval b ] - mkpart partnum offset p = + mkpart partnum startpos endpos p = [ "mkpart" , pval (partType p) , pval (partFs p) - , pval offset - , pval (offset <> partSize p) + , partposexact startpos + , partposfuzzy endpos ] ++ case partName p of Just n -> ["name", show partnum, n] Nothing -> [] - mkparts partnum offset (p:ps) c = - mkparts (partnum+1) (offset <> partSize p) ps - (c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p)) - mkparts _ _ [] c = c + calcparts partnum startpos (p:ps) c = + let endpos = startpos + align (partSize p) + in calcparts (partnum+1) endpos ps + (c ++ mkpart partnum startpos (endpos-1) p : map (mkflag partnum) (partFlags p)) + calcparts _ endpos [] c = (c, endpos) + + -- Exact partition position value for parted. + -- For alignment to work, the start of a partition must be + -- specified exactly. + partposexact n + | n > 0 = show n ++ "B" + -- parted can't make partitions smaller than 1MB; + -- avoid failure in edge cases + | otherwise = "1MB" + + -- Fuzzy partition position valie for parted. + -- This is used to specify the end of the partition, + -- parted takes the "MB" as license to slightly reduce the + -- partition size when something about the partition table + -- does not allow the partition to end exactly at the position. + partposfuzzy n + | n > 0 = show (fromIntegral n / 1000000 :: Double) ++ "MB" + | otherwise = "1MB" + + -- Location of the start of the first partition, + -- leaving space for the partition table, and aligning. + firstpos = align partitionTableOverhead + + align = alignTo alignment -- | Runs parted on a disk with the specified parameters. -- -- Parted is run in script mode, so it will never prompt for input. --- It is asked to use cylinder alignment for the disk. parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux) parted YesReallyDeleteDiskContents disk ps = p `requires` installed where - p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) + p = cmdProperty "parted" ("--script":"--align":"none":disk:ps) `assume` MadeChange -- | Gets parted installed. installed :: Property (DebianLike + ArchLinux) installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"] --- | Gets the total size of the disk specified by the partition table. -partTableSize :: PartTable -> ByteSize -partTableSize (PartTable _ ps) = fromPartSize $ - mconcat (partitionTableOverhead : map partSize ps) - -- | Some disk is used to store the partition table itself. Assume less -- than 1 mb. partitionTableOverhead :: PartSize @@ -112,27 +142,27 @@ partitionTableOverhead = MegaBytes 1 -- -- For example: -- --- > calcPartTable (DiskSize (1024 * 1024 * 1024 * 100)) MSDOS +-- > calcPartTable (DiskSize (1024 * 1024 * 1024 * 100)) MSDOS safeAlignment -- > [ partition EXT2 `mountedAt` "/boot" -- > `setSize` MegaBytes 256 -- > `setFlag` BootFlag -- > , partition EXT4 `mountedAt` "/" --- > `useDisk` RemainingSpace +-- > `useDiskSpace` RemainingSpace -- > ] -calcPartTable :: DiskSize -> TableType -> [PartSpec DiskPart] -> PartTable -calcPartTable (DiskSize disksize) tt l = PartTable tt (map go l) +calcPartTable :: DiskSize -> TableType -> Alignment -> [PartSpec DiskPart] -> PartTable +calcPartTable (DiskSize disksize) tt alignment l = + PartTable tt alignment (map go l) where go (_, _, mkpart, FixedDiskPart) = mkpart defSz - go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ toPartSize $ + go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ Bytes $ diskremainingafterfixed * fromIntegral p `div` 100 - go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ toPartSize $ + go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ Bytes $ diskremaining `div` genericLength (filter isremainingspace l) - diskremainingafterfixed = + diskremainingafterfixed = disksize - sumsizes (filter isfixed l) diskremaining = disksize - sumsizes (filter (not . isremainingspace) l) - sumsizes = sum . map fromPartSize . (partitionTableOverhead :) . - map (partSize . go) + sumsizes = partTableSize . PartTable tt alignment . map go isfixed (_, _, _, FixedDiskPart) = True isfixed _ = False isremainingspace (_, _, _, DynamicDiskPart RemainingSpace) = True @@ -177,3 +207,14 @@ defSz = MegaBytes 128 -- Add an additional 200 mb for temp files, journals, etc. fudgeSz :: PartSize -> PartSize fudgeSz (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) +fudgeSz (Bytes n) = fudgeSz (toPartSize n) + +alignTo :: Alignment -> PartSize -> ByteSize +alignTo _ (Bytes n) = n -- no alignment done for Bytes +alignTo (Alignment alignment) partsize + | alignment < 1 = n + | otherwise = case rem n alignment of + 0 -> n + r -> n - r + alignment + where + n = fromPartSize partsize diff --git a/src/Propellor/Property/Parted/Types.hs b/src/Propellor/Property/Parted/Types.hs @@ -1,6 +1,5 @@ module Propellor.Property.Parted.Types where -import Propellor.Base import qualified Propellor.Property.Partition as Partition import Utility.DataUnits @@ -17,14 +16,16 @@ instance PartedVal TableType where pval = map toLower . show -- | A disk's partition table. -data PartTable = PartTable TableType [Partition] +data PartTable = PartTable TableType Alignment [Partition] deriving (Show) instance Monoid PartTable where - -- | default TableType is MSDOS - mempty = PartTable MSDOS [] + -- | default TableType is MSDOS, with a `safeAlignment`. + mempty = PartTable MSDOS safeAlignment [] -- | uses the TableType of the second parameter - mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) + -- and the larger alignment, + mappend (PartTable _l1 a1 ps1) (PartTable l2 a2 ps2) = + PartTable l2 (max a1 a2) (ps1 ++ ps2) -- | A partition on the disk. data Partition = Partition @@ -57,33 +58,51 @@ instance PartedVal PartType where pval Logical = "logical" pval Extended = "extended" --- | All partition sizing is done in megabytes, so that parted can --- automatically lay out the partitions. --- --- Note that these are SI megabytes, not mebibytes. -newtype PartSize = MegaBytes Integer +-- | Size of a partition. +data PartSize + -- Since disk sizes are typically given in MB, not MiB, this + -- uses SI MegaBytes (powers of 10). + = MegaBytes Integer + -- For more control, the partition size can be given in bytes. + -- Note that this will prevent any automatic alignment from + -- being done. + | Bytes Integer deriving (Show) -instance PartedVal PartSize where - pval (MegaBytes n) - | n > 0 = val n ++ "MB" - -- parted can't make partitions smaller than 1MB; - -- avoid failure in edge cases - | otherwise = "1MB" - -- | Rounds up to the nearest MegaByte. toPartSize :: ByteSize -> PartSize -toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double) +toPartSize = toPartSize' ceiling + +toPartSize' :: (Double -> Integer) -> ByteSize -> PartSize +toPartSize' rounder b = MegaBytes $ rounder (fromInteger b / 1000000 :: Double) fromPartSize :: PartSize -> ByteSize fromPartSize (MegaBytes b) = b * 1000000 +fromPartSize (Bytes n) = n instance Monoid PartSize where mempty = MegaBytes 0 mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) + mappend (Bytes a) b = Bytes (a + fromPartSize b) + mappend a (Bytes b) = Bytes (b + fromPartSize a) reducePartSize :: PartSize -> PartSize -> PartSize reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b) +reducePartSize (Bytes a) b = Bytes (a - fromPartSize b) +reducePartSize a (Bytes b) = Bytes (fromPartSize a - b) + +-- | Partitions need to be aligned for optimal efficiency. +-- The alignment is a number of bytes. +newtype Alignment = Alignment ByteSize + deriving (Show, Eq, Ord) + +-- | 4MiB alignment is optimal for inexpensive flash drives and +-- is a good safe default for all drives. +safeAlignment :: Alignment +safeAlignment = Alignment (4*1024*1024) + +fromAlignment :: Alignment -> ByteSize +fromAlignment (Alignment n) = n -- | Flags that can be set on a partition. data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag @@ -106,6 +125,8 @@ instance PartedVal Bool where pval True = "on" pval False = "off" +-- This is used for creating partitions, not formatting partitions, +-- so it's ok to use eg, fat32 for both FAT and VFAT. instance PartedVal Partition.Fs where pval Partition.EXT2 = "ext2" pval Partition.EXT3 = "ext3" @@ -113,7 +134,7 @@ instance PartedVal Partition.Fs where pval Partition.BTRFS = "btrfs" pval Partition.REISERFS = "reiserfs" pval Partition.XFS = "xfs" - pval Partition.FAT = "fat" - pval Partition.VFAT = "vfat" + pval Partition.FAT = "fat32" + pval Partition.VFAT = "fat32" pval Partition.NTFS = "ntfs" pval Partition.LinuxSwap = "linux-swap" diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs @@ -48,6 +48,14 @@ To take advantage of the piuparts and autopkgtest support, add to your > > $autopkgtest_root_args = ""; > $autopkgtest_opts = ["--", "schroot", "%r-%a-sbuild"]; + +On Debian jessie hosts, you should ensure that sbuild and autopkgtest come from +the same suite. This is because the autopkgtest binary changed its name between +jessie and stretch. If you have not installed backports of sbuild or +autopkgtest, you don't need to do anything. But if you have installed either +package from jessie-backports (with Propellor or otherwise), you should install +the other from jessie-backports, too. + -} module Propellor.Property.Sbuild ( @@ -376,6 +384,13 @@ ccachePrepared = propertyList "sbuild group ccache configured" $ props -- -- You probably want a custom ~/.sbuildrc on your workstation, but -- this property is handy for quickly setting up build boxes. +-- +-- On Debian jessie hosts, you should ensure that sbuild and autopkgtest come +-- from the same suite. This is because the autopkgtest binary changed its name +-- between jessie and stretch. If you have not installed backports of sbuild or +-- autopkgtest, you don't need to do anything. But if you have installed either +-- package from jessie-backports (with Propellor or otherwise), you should +-- install the other from jessie-backports, too. userConfig :: User -> Property DebianLike userConfig user@(User u) = go `requires` usableBy user diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -181,6 +181,8 @@ armAutoBuilder suite arch flavor = -- Works around ghc crash with parallel builds on arm. & (homedir </> ".cabal" </> "config") `File.lacksLine` "jobs: $ncpus" + -- Work around https://github.com/systemd/systemd/issues/7135 + & Systemd.containerCfg "--system-call-filter=set_tls" androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container androidAutoBuilderContainer crontimes timeout = diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -646,7 +646,7 @@ dkimInstalled = go `onChange` Service.restarted "opendkim" & Apt.serviceInstalledRunning "opendkim" & File.dirExists "/etc/mail" & File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") - & File.ownerGroup "/etc/mail/dkim.key" (User "opendkim") (Group "opendkim") + & File.ownerGroup "/etc/mail/dkim.key" (User "root") (Group "root") & "/etc/default/opendkim" `File.containsLine` "SOCKET=\"inet:8891@localhost\"" `onChange` @@ -906,8 +906,8 @@ alarmClock oncalendar (User user) command = combineProperties "goodmorning timer ("Login", "LidSwitchIgnoreInhibited", "no") -- My home power monitor. -homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike) -homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props +homePowerMonitor :: IsContext c => User -> [Host] -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike) +homePowerMonitor user hosts ctx sshkey = propertyList "home power monitor" $ props & Apache.installed & Apt.installed ["python", "python-pymodbus", "rrdtool", "rsync"] & File.ownerGroup "/var/www/html" user (userGroup user) @@ -923,6 +923,7 @@ homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props `requires` File.ownerGroup (takeDirectory sshkeyfile) user (userGroup user) `requires` File.dirExists (takeDirectory sshkeyfile) + `requires` Ssh.knownHost hosts "kitenet.net" user where d = "/var/www/html/homepower" sshkeyfile = d </> ".ssh/key" @@ -1033,3 +1034,47 @@ ipmasq intif = File.hasContent ifupscript ifupscript = "/etc/network/if-up.d/ipmasq" pppupscript = "/etc/ppp/ip-up.d/ipmasq" scriptmode f = f `File.mode` combineModes (readModes ++ executeModes) + +laptopSoftware :: Property DebianLike +laptopSoftware = Apt.installed + [ "procmeter3", "xfce4", "procmeter3", "unclutter" + , "mplayer", "fbreader", "firefox", "chromium" + , "libdatetime-event-sunrise-perl", "libtime-duration-perl" + , "iftop", "network-manager", "gtk-redshift", "powertop" + , "gimp", "gthumb", "inkscape", "sozi", "xzgv", "hugin" + , "mpc", "mpd", "ncmpc", "sonata", "mpdtoys" + , "bsdgames", "nethack" + , "xmonad", "libghc-xmonad-dev", "libghc-xmonad-contrib-dev" + , "ttf-bitstream-vera" + , "mairix", "offlineimap", "mutt" + , "nmap" + , "udevil", "pmount" + , "arbtt", "hledger", "bc" + , "apache2", "ikiwiki", "libhighlight-perl" + , "pal" + , "yeahconsole", "xkbset", "xinput" + , "assword", "pumpa", "vorbis-tools" + , "xul-ext-ublock-origin", "xul-ext-pdf.js", "xul-ext-status4evar" + , "vim-syntastic", "vim-fugitive" + , "adb", "gthumb" + , "w3m", "sm", "weechat" + , "borgbackup", "wipe" + ] + `requires` baseSoftware + `requires` devSoftware + +baseSoftware :: Property DebianLike +baseSoftware = Apt.installed + [ "bash", "bash-completion", "vim", "screen", "less", "moreutils" + , "git", "mr", "etckeeper", "git-annex", "ssh", "vim-vimoutliner" + ] + +devSoftware :: Property DebianLike +devSoftware = Apt.installed + [ "build-essential", "debhelper", "devscripts" + , "ghc", "cabal-install", "haskell-stack" + , "hothasktags", "hdevtools", "hlint" + , "gdb", "dpkg-repack", "lintian" + , "pristine-tar", "github-backup" + , "kvm" + ] diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs @@ -7,13 +7,16 @@ import Propellor.Types.Info -- | Boot loader installed on a host. data BootloaderInstalled - = GrubInstalled + = GrubInstalled GrubTarget | FlashKernelInstalled | UbootInstalled (FilePath -> FilePath -> Property Linux) deriving (Typeable) +-- | Platforms that grub can boot. +data GrubTarget = PC | EFI64 | EFI32 | Coreboot | Xen + instance Show BootloaderInstalled where - show GrubInstalled = "GrubInstalled" + show (GrubInstalled _) = "GrubInstalled" show FlashKernelInstalled = "FlashKernelInstalled" show (UbootInstalled _) = "UbootInstalled"