propellor

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

commit 31d05456281fad3d64fee5fd11f9f9902e9bb99c
parent 236ae3b0d33fe637a29851c2135ccf6ac32b781e
Author: rsiddharth <s@ricketyspace.net>
Date:   Mon, 28 Aug 2017 17:37:52 -0400

Merge remote-tracking branch 'upstream/master'

Diffstat:
Makefile | 5-----
config-freebsd.hs | 2+-
debian/changelog | 439++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
debian/compat | 2+-
debian/control | 16+++++++++-------
doc/README.mdwn | 6++++--
joeyconfig.hs | 196++++++++++++++++++++++++++++++++++++++-----------------------------------------
propellor.cabal | 43++++++++++++++++++++++++++++++-------------
src/Propellor/Bootstrap.hs | 203+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------------
src/Propellor/CmdLine.hs | 53++++++++++++++++++++++++++++++++++++-----------------
src/Propellor/Container.hs | 21++++++++++++++++++---
src/Propellor/DotDir.hs | 6+++---
src/Propellor/Engine.hs | 60+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
src/Propellor/EnsureProperty.hs | 4++--
src/Propellor/Gpg.hs | 34++++++++++++++++++++++++++++------
src/Propellor/Info.hs | 9+++++++--
src/Propellor/Message.hs | 58++++++++++++++++++++++++++++++----------------------------
src/Propellor/PrivData.hs | 10++++------
src/Propellor/Property.hs | 60++++++++++++++++++++++++++++++++----------------------------
src/Propellor/Property/Apache.hs | 36+++++++++++++++++++++++++++---------
src/Propellor/Property/Apt.hs | 193++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------
src/Propellor/Property/Apt/PPA.hs | 30+++++++++++++++---------------
src/Propellor/Property/Attic.hs | 16++++++++++------
src/Propellor/Property/Bootstrap.hs | 144+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Borg.hs | 10+++++-----
src/Propellor/Property/Ccache.hs | 2+-
src/Propellor/Property/Chroot.hs | 122+++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------------------
src/Propellor/Property/Cmd.hs | 1+
src/Propellor/Property/Concurrent.hs | 11+++++++----
src/Propellor/Property/Conductor.hs | 6+++---
src/Propellor/Property/ConfFile.hs | 25+++++++++++++++++++++++++
src/Propellor/Property/Cron.hs | 5+++--
src/Propellor/Property/DebianMirror.hs | 2+-
src/Propellor/Property/Debootstrap.hs | 3++-
src/Propellor/Property/DiskImage.hs | 248+++++++++++++++++++++++++++++++++++++++++++++++++------------------------------
src/Propellor/Property/DiskImage/PartSpec.hs | 80++++++++++++++++---------------------------------------------------------------
src/Propellor/Property/Dns.hs | 14+++++++-------
src/Propellor/Property/Docker.hs | 28++++++++++++++--------------
src/Propellor/Property/File.hs | 119+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
src/Propellor/Property/Firejail.hs | 2+-
src/Propellor/Property/Firewall.hs | 77++++++++++++++++++++++++++++++++++++++---------------------------------------
src/Propellor/Property/FreeBSD/Pkg.hs | 5+++--
src/Propellor/Property/FreeBSD/Poudriere.hs | 14++++++++------
src/Propellor/Property/FreeDesktop.hs | 29+++++++++++++++++++++++++++++
src/Propellor/Property/Fstab.hs | 29+++++++++++++++++++++--------
src/Propellor/Property/Gpg.hs | 2--
src/Propellor/Property/Grub.hs | 72++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
src/Propellor/Property/HostingProvider/Linode.hs | 5+++--
src/Propellor/Property/Hostname.hs | 2+-
src/Propellor/Property/LightDM.hs | 13+++++++++----
src/Propellor/Property/List.hs | 9++++++++-
src/Propellor/Property/Locale.hs | 6++++--
src/Propellor/Property/Logcheck.hs | 12++++++------
src/Propellor/Property/Mount.hs | 23++++++++++++++++++++++-
src/Propellor/Property/Network.hs | 70+++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------
src/Propellor/Property/OS.hs | 4++--
src/Propellor/Property/Obnam.hs | 7+++++--
src/Propellor/Property/OpenId.hs | 2+-
src/Propellor/Property/Pacman.hs | 68++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Parted.hs | 219++++++++++++++++++++++++++++++++-----------------------------------------------
src/Propellor/Property/Parted/Types.hs | 119+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Partition.hs | 24++++++++++++++++++++----
src/Propellor/Property/Reboot.hs | 19++++++++++---------
src/Propellor/Property/Restic.hs | 202+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Rsync.hs | 16++++++++++------
src/Propellor/Property/Sbuild.hs | 227++++++++++++++++++++++++++++++++++++-------------------------------------------
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 15++++++++++++---
src/Propellor/Property/SiteSpecific/JoeySites.hs | 245+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------
src/Propellor/Property/Ssh.hs | 12++++++------
src/Propellor/Property/Sudo.hs | 24+++++++++++++++++-------
src/Propellor/Property/Systemd.hs | 74+++++++++++++++++++++++++++++++-------------------------------------------
src/Propellor/Property/Timezone.hs | 21+++++++++++++++++++++
src/Propellor/Property/Tor.hs | 34+++++++++++++++++++++++++---------
src/Propellor/Property/Unbound.hs | 4++--
src/Propellor/Property/User.hs | 35+++++++++++++++++++++++++----------
src/Propellor/Property/Versioned.hs | 124+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/XFCE.hs | 41+++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/ZFS/Process.hs | 3++-
src/Propellor/Shim.hs | 2--
src/Propellor/Spin.hs | 119++++++++++++++++++++++++++++++++++++++++++++++++-------------------------------
src/Propellor/Ssh.hs | 18++++++++----------
src/Propellor/Types.hs | 58+++++++++++++++++++++++++++++++++++++++++++++++++++++-----
src/Propellor/Types/Bootloader.hs | 12++++++++++++
src/Propellor/Types/Chroot.hs | 2+-
src/Propellor/Types/CmdLine.hs | 1+
src/Propellor/Types/ConfigurableValue.hs | 44++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Core.hs | 7++++---
src/Propellor/Types/Dns.hs | 23++++++++++++-----------
src/Propellor/Types/Docker.hs | 2+-
src/Propellor/Types/Info.hs | 23+++++++++++++----------
src/Propellor/Types/MetaTypes.hs | 28++++++++++++++++++++++++++--
src/Propellor/Types/OS.hs | 29+++++++++++++++++++++--------
src/Propellor/Types/PartSpec.hs | 66++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Result.hs | 3+++
src/Propellor/Types/ZFS.hs | 79++++++++++++++++++++++++++++++++++++++++++-------------------------------------
src/Utility/DataUnits.hs | 8++++++--
src/Utility/Exception.hs | 26+++++++++++++++++++++++---
src/Utility/FileMode.hs | 22++++++++++++++++++++--
src/Utility/FileSystemEncoding.hs | 74+++++++++++++++++++++++++++++++++++++++++++++++---------------------------
src/Utility/LinuxMkLibs.hs | 2+-
src/Utility/Misc.hs | 17-----------------
src/Utility/PartialPrelude.hs | 2+-
src/Utility/Path.hs | 32+++++++++++---------------------
src/Utility/Process.hs | 28+++++++++++++---------------
src/Utility/SafeCommand.hs | 4++--
src/Utility/Scheduled.hs | 2+-
src/Utility/Split.hs | 30++++++++++++++++++++++++++++++
src/Utility/SystemDirectory.hs | 2+-
src/Utility/Tuple.hs | 17+++++++++++++++++
src/Utility/UserInfo.hs | 16+++++++++-------
src/propellor-config.hs | 2++
src/wrapper.hs | 5++++-
stack.yaml | 2+-
113 files changed, 3714 insertions(+), 1324 deletions(-)

diff --git a/Makefile b/Makefile @@ -1,11 +1,6 @@ CABAL?=cabal DATE := $(shell dpkg-parsechangelog 2>/dev/null | grep Date | cut -d " " -f2-) -# this target is provided (and is first) to keep old versions of the -# propellor cron job working, and will eventually be removed -run: build - ./propellor - build: tags propellor.1 dist/setup-config $(CABAL) build ln -sf dist/build/propellor-config/propellor-config propellor diff --git a/config-freebsd.hs b/config-freebsd.hs @@ -59,7 +59,7 @@ linuxbox = host "linuxbox.example.com" $ props -- A generic webserver in a Docker container. webserverContainer :: Docker.Container webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props - & osDebian' KFreeBSD (Stable "jessie") X86_64 + & osDebian' KFreeBSD (Stable "stretch") X86_64 & Apt.stdSourcesList & Docker.publish "80:80" & Docker.volume "/var/www:/var/www" diff --git a/debian/changelog b/debian/changelog @@ -1,9 +1,437 @@ -propellor (3.2.3-1+b1) sid; urgency=low, binary-only=yes +propellor (4.7.7-1) unstable; urgency=medium - * Binary-only non-maintainer upload for amd64; no source changes. - * rebuild with PIE + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 26 Aug 2017 11:39:06 -0700 + +propellor (4.7.7) unstable; urgency=medium + + * Locale: Display an error message when /etc/locale.gen does not contain + the requested locale. + * Attic module is deprecated and will warn when used. + Attic is no longer available in Debian and appears to have been + mostly supersceded by Borg. + * Obnam module is deprecated and will warn when used. + Obnam has been retired by its author. + * Add Typeable instance to Bootstrapper, fixing build with old versions + of ghc. (Previous attempt was incomplete.) + + -- Joey Hess <id@joeyh.name> Wed, 23 Aug 2017 12:15:31 -0400 + +propellor (4.7.6-1) unstable; urgency=medium + + * Package new upstream release. + * Bump debhelper compat to 10. + * Bump std-ver to 4.0.1 (no changes required). + + -- Sean Whitton <spwhitton@spwhitton.name> Thu, 17 Aug 2017 17:30:30 -0700 + +propellor (4.7.6) unstable; urgency=medium + + * Sbuild: Add Sbuild.userConfig property. + Thanks, Sean Whitton + * Locale: Make sure that the locales package is installed when enabling + locales. + + -- Joey Hess <id@joeyh.name> Tue, 01 Aug 2017 17:59:07 -0400 + +propellor (4.7.5) unstable; urgency=medium + + * Avoid crashing when getTerminalName fails due to eg, being in a chroot. + + -- Joey Hess <id@joeyh.name> Tue, 01 Aug 2017 15:28:58 -0400 + +propellor (4.7.4) unstable; urgency=medium + + * Set GPG_TTY when run at a terminal, so that gpg can do password + prompting despite being connected by pipes to propellor (or git). + * Rsync: Make rsync display less verbose. + * Improve PROPELLOR_TRACE output so serialized trace values always + come on their own line, not mixed with title setting. + + -- Joey Hess <id@joeyh.name> Tue, 01 Aug 2017 13:30:54 -0400 + +propellor (4.7.3) unstable; urgency=medium + + * Expand the Trace data type. + + -- Joey Hess <id@joeyh.name> Sat, 29 Jul 2017 17:26:32 -0400 + +propellor (4.7.2) unstable; urgency=medium + + * Added PROPELLOR_TRACE environment variable, which can be set to 1 to + make propellor output serialized Propellor.Message.Trace values, + for consumption by another program. + * Rsync: Make rsync display its progress, in a minimal format to avoid + scrolling each file down the screen. + + -- Joey Hess <id@joeyh.name> Sat, 29 Jul 2017 15:49:00 -0400 + +propellor (4.7.1) unstable; urgency=medium + + * Added Mount.isMounted. + * Grub.bootsMounted: Bugfix. + + -- Joey Hess <id@joeyh.name> Fri, 28 Jul 2017 22:22:40 -0400 + +propellor (4.7.0) unstable; urgency=medium + + * Add Apt.proxy property to set a host's apt proxy. + Thanks, Sean Whitton. + * Add Apt.useLocalCacher property to set up apt-cacher-ng. + Thanks, Sean Whitton. + * Rework Sbuild properties to use apt proxies/cachers instead of + bind-mounting the host's apt cache. This makes it possible to run more + than one build at a time, and lets sbuild run even if apt's cache is + locked by the host's apt. + Thanks, Sean Whitton. + * Sbuild: When Apt.proxy is set, it is assumed that the proxy does some + sort of caching, and sbuild chroots are set up to use the same proxy. + * Sbuild: When Apt.proxy is not set, install apt-cacher-ng, and point + sbuild chroots at the local apt cacher. + * Sbuild: Droped Sbuild.piupartsConfFor, Sbuild.piupartsConf, + Sbuild.shareAptCache + (API change) + No longer needed now that we are using apt proxies/cachers. + * Sbuild: Updated sample config in haddock for Propellor.Property.Sbuild. + If you use this module, please compare both your config.hs and + your ~/.sbuildrc with the haddock documentation. + * Grub.bootsMounted: Avoid failing when proc sys etc are already mounted + within the chroot. + + -- Joey Hess <id@joeyh.name> Fri, 28 Jul 2017 20:42:35 -0400 + +propellor (4.6.2) unstable; urgency=medium + + * Systemd.nspawned: Recent systemd versions such as 234 ignore + non-symlinks in /etc/systemd/system/multi-user.target.wants, + which was used to configure systemd-nspawn parameters. Instead, + use a service.d/local.conf file to configure that. + * Grub: Added bootsMounted property, a generalization of + DiskImage.grubBooted + + -- Joey Hess <id@joeyh.name> Fri, 28 Jul 2017 15:48:32 -0400 + +propellor (4.6.1) unstable; urgency=medium + + * Added Network.dhcp' and Network.static', which allow specifying + additional options for interfaces files. + * Fix build failure on ghc-8.2.1 + Thanks, Sergei Trofimovich. + * DiskImage: Fix strictness bug in .parttable read/write sequence. + + -- Joey Hess <id@joeyh.name> Thu, 27 Jul 2017 09:17:32 -0400 + +propellor (4.6.0) unstable; urgency=medium + + * Add Typeable instance to Bootstrapper, fixing build with old versions + of ghc. + * Network.static changed to take address and gateway parameters. + If you used the old Network.static property, it has been renamed to + Network.preserveStatic. + (Minor API change) + + -- Joey Hess <id@joeyh.name> Wed, 26 Jul 2017 20:02:50 -0400 + +propellor (4.5.2) unstable; urgency=medium + + * Added Rsync.installed property. + * Added DiskImage.vmdkBuiltFor property which is useful for booting + a disk image in VirtualBox. + + -- Joey Hess <id@joeyh.name> Tue, 25 Jul 2017 17:58:46 -0400 + +propellor (4.5.1) unstable; urgency=medium + + * Reboot.toKernelNewerThan: If running kernel is new enough, avoid + looking at what kernels are installed. + Thanks, Sean Whitton. + * DiskImage: Avoid re-partitioning disk image unncessarily, for a large + speedup. + + -- Joey Hess <id@joeyh.name> Tue, 25 Jul 2017 15:51:33 -0400 + +propellor (4.5.0) unstable; urgency=medium + + * Generalized the PartSpec DSL, so it can be used for both + disk image partitioning, and disk device partitioning, with + different partition sizing methods as appropriate for the different + uses. (minor API change) + * Propellor.Property.Parted: Added calcPartTable function which uses + PartSpec DiskPart, and a useDiskSpace combinator. + * Generate a better description for versioned properties. + + -- Joey Hess <id@joeyh.name> Fri, 21 Jul 2017 16:40:13 -0400 + +propellor (4.4.0) unstable; urgency=medium + + * Propellor.Property.Timezone: New module, contributed by Sean Whitton. + * Propellor.Property.Sudo.enabledFor: Made revertable. + (minor API change) + * Propellor.Property.LightDM.autoLogin: Made revertable. + (minor API change) + * Propellor.Property.Conffile: Added lacksIniSetting. + + -- Joey Hess <id@joeyh.name> Mon, 17 Jul 2017 12:55:02 -0400 + +propellor (4.3.4) unstable; urgency=medium + + * Propellor.Property.Versioned: New module which allows different + versions of a property or host to be written down in a propellor config + file. Has many applications, including staged upgrades and rollbacks. + * LightDM.autoLogin: Use [Seat:*] rather than the old [SeatDefaults]. + The new name has been supported since lightdm 1.15. + + -- Joey Hess <id@joeyh.name> Sat, 15 Jul 2017 17:22:53 -0400 + +propellor (4.3.3) unstable; urgency=medium + + * Hosts can be configured to build propellor using stack, by adding + a property: + & bootstrapWith (Robustly Stack) + * Hosts can be configured to build propellor using cabal, but using + only packages installed from the operating system. This + will work on eg Debian: + & bootstrapWith OSOnly + * Iproved fix for bug that sometimes made --spin fail with + "fatal: Couldn't find remote ref HEAD". The previous fix didn't work + reliably. + * User: add systemGroup and use it for systemAccountFor' + Thanks, Félix Sipma. + * Export a Restic.backup' property. + Thanks, Félix Sipma. + * Updated stack config to lts-8.22. + + -- Joey Hess <id@joeyh.name> Thu, 13 Jul 2017 12:34:09 -0400 + +propellor (4.3.2) unstable; urgency=medium + + * Really include Propellor.Property.FreeDesktop. + + -- Joey Hess <id@joeyh.name> Thu, 06 Jul 2017 17:28:53 -0400 + +propellor (4.3.1) unstable; urgency=medium + + * Added Propellor.Property.FreeDesktop module. + * Added reservedSpacePercentage to the PartSpec EDSL. + + -- Joey Hess <id@joeyh.name> Thu, 06 Jul 2017 17:03:15 -0400 + +propellor (4.3.0) unstable; urgency=medium + + * DiskImage: Removed grubBooted; properties that used to need it as a + parameter now look at Info about the bootloader that is installed in + the chroot that the disk image is created from. + (API change) + + -- Joey Hess <id@joeyh.name> Wed, 05 Jul 2017 21:04:04 -0400 + +propellor (4.2.0) unstable; urgency=medium + + * DiskImage.grubBooted no longer takes a BIOS parameter, + and no longer implicitly adds Grub.installed to the properties of + the disk image. If you used DiskImage.grubBooted, you'll need to update + your propellor configuration, removing the BIOS parameter from + grubBooted and adding a Grub.installed property to the disk image, eg: + & Grub.installed PC + (API change) + * Grub.installed: Avoid running update-grub when used in a chroot, since + it will get confused. + * DiskImage.Finalization: Simplified this type since it does not need to + be used to install packages anymore. (API change) + + -- Joey Hess <id@joeyh.name> Wed, 05 Jul 2017 18:10:49 -0400 + +propellor (4.1.0) unstable; urgency=medium + + * User.hasInsecurePassword makes sure shadow passwords are enabled, + so if the insecure password is later changed, the new password won't be + exposed. + * Bugfix: Apache.httpsVirtualHost' must create ssl/hn/ dir earlier + Thanks, Sean Whitton. + * Bootstrap.clonedFrom: Fix bug that broke copying .git/config into + chroot. + * Diskimage.imageExists: Align disk image size to multiple of 4096 + sector size, since some programs (such as VBoxManage convertdd) + refuse to operate on disk images not aligned to a sector size. + * Bootstrap.bootstrappedFrom: Fix bug that caused propellor to only + be built from the bootstrapped config the first time. + * Bootstrap.bootstrappedFrom: Avoid doing anything when not run in a + chroot. + * When provisioning a container, output was buffered until the whole + process was done; now output will be displayed immediately. + * LightDM.autoLogin: Make it require LightDM.installed. + (minor API change as the type changed) + * Propellor.Property.XFCE added with some useful properties for the + desktop environment. + * Added File.applyPath property. + * Added File.checkOverwrite. + * File.isCopyOf: Fix bug that prevented this property from working + when the destination file did not yet exist. + + -- Joey Hess <id@joeyh.name> Wed, 05 Jul 2017 17:30:00 -0400 + +propellor (4.0.6-1) unstable; urgency=medium + + * Package new upstream release. + - Drop {build-,}dependency on libghc-missingh-{dev,prof} + - Add {build-,}dependencies on libghc-{split,hashable}-{dev,prof}. + * Bump standards version to 4.0.0 (no changes required). + * Update Vcs-Browser URI. + + -- Sean Whitton <spwhitton@spwhitton.name> Wed, 21 Jun 2017 13:41:27 +0100 + +propellor (4.0.6) unstable; urgency=medium + + * Fix bug that sometimes made --spin fail with + "fatal: Couldn't find remote ref HEAD" + * Display error and warning messages to stderr, not stdout. + + -- Joey Hess <id@joeyh.name> Sun, 18 Jun 2017 19:30:50 -0400 + +propellor (4.0.5) unstable; urgency=medium + + * Switch cabal file from Extensions to Default-Extensions to fix + new picky hackage rejection. + + -- Joey Hess <id@joeyh.name> Sat, 03 Jun 2017 15:07:36 -0400 + +propellor (4.0.4) unstable; urgency=medium + + * Propellor.Property.Restic added for yet another backup program. + Thanks, Félix Sipma. + * Removed dependency on MissingH, instead depends on split and hashable. + + -- Joey Hess <id@joeyh.name> Sat, 03 Jun 2017 14:56:44 -0400 + +propellor (4.0.3) unstable; urgency=medium + + * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. + Thanks, Daniel Brooks. + * Added Propellor.Property.Bootstrap, which can be used to make + disk images contain their own installation of propellor. + + -- Joey Hess <id@joeyh.name> Thu, 20 Apr 2017 00:54:32 -0400 + +propellor (4.0.2) unstable; urgency=medium + + * Apt.mirror can be used to set the preferred apt mirror of a host, + overriding the default CDN. This info is used by + Apt.stdSourcesList and Sbuild.builtFor. + Thanks, Sean Whitton. + * Property.Partition: Update kpartx output parser, as its output format + changed around version 0.6. Both output formats are supported now. + * Fix bug when using setContainerProps with a chroot that prevented + properties added to a chroot that way from being seen when propellor + was running inside the chroot. This affected disk image creation, and + possibly other things that use chroots. + + -- Joey Hess <id@joeyh.name> Fri, 24 Mar 2017 14:04:50 -0400 + +propellor (4.0.1) unstable; urgency=medium + + * Fix build with pre-AMP ghc. + * Tor: Restart daemon after installing private key. + * Tor.named, Tor.torPrivKey: Include the new ed25519 public/private key + pair in addition to the old secret_id_key. + + -- Joey Hess <id@joeyh.name> Sun, 19 Mar 2017 16:18:11 -0400 + +propellor (4.0.0) unstable; urgency=medium + + * Added Monoid instances for Property and RevertableProperty. + * Removed applyToList. Instead, use mconcat. (API change) + If you had: applyToList accountFor [User "joey", User "root"] + use instead: mconcat (map accountFor [User "joey", User "root"]) + * Makefile: Removed "run" target which was default target. + "make" now only builds propellor, does not run it. + Note that propellor 1.0.0 and earlier relied on this target for + the Cron.runPropellor property's cronjob to work, so upgrading + directly from 1.0.0 to 4.0.0 would break that cron job. + * Remove make from propellor's dependency list; it's not used by + propellor any longer. + * Implemented hostChroot, as originally seen in my slides at + Linux.Conf.Au 2017 in January. Now that it's not vaporware, it allows + one Host to build a disk image that has all the properties of another + Host. + * DiskImage building properties used to propagate DNS info out from + the chroot used to build the disk image to the Host. That is no longer + done, since that chroot only exists as a side effect of the disk image + creation and servers will not be running in it. + * The IsInfo types class's propagateInfo function changed to use a + PropagateInfo data type. (API change) + * The action used to satisfy a property changed to Maybe (Propellor Result). + When it is Nothing, propellor knows it can skip displaying the + description of that property. This is mostly useful in the + implementation of mempty. (API change) + * The doNothing property is now simply mempty. The name was retained + because it can be clearer than mempty in some contexts. + * Added Apache.confEnabled. + + -- Joey Hess <id@joeyh.name> Wed, 15 Mar 2017 15:46:42 -0400 + +propellor (3.4.1) unstable; urgency=medium + + * Fixed https url to propellor git repository. + + -- Joey Hess <id@joeyh.name> Wed, 01 Mar 2017 16:50:05 -0400 + +propellor (3.4.0) unstable; urgency=medium + + * Added ConfigurableValue type class, for values that can be used in a + config file, or to otherwise configure a program. + * The val function converts such values to String. + * Removed fromPort and fromIPAddr (use val instead). (API change) + * Removed several Show instances that were only used for generating + configuration, replacing with ConfigurableValue instances. (API change) + * The github mirror of propellor's git repository has been removed, + since github's terms of service has started imposing unwanted licensing + requirements. + * propellor --init: The option to clone propellor's git repository + used to use the github mirror, and has been changed to use a different + mirror. + + -- Joey Hess <id@joeyh.name> Wed, 01 Mar 2017 16:44:20 -0400 + +propellor (3.3.1) unstable; urgency=medium + + * Apt: Removed the mirrors.kernel.org line from stdSourcesList etc. + The mirror CDN has a new implementation that should avoid the problems + with httpredir that made an extra mirror sometimes be needed. + * Switch Debian CDN address to deb.debian.org. + * Tor.hiddenService: Fix bug in torrc's HiddenServicePort configuration. + Thanks, Félix Sipma + + -- Joey Hess <id@joeyh.name> Mon, 20 Feb 2017 13:49:26 -0400 + +propellor (3.3.0) unstable; urgency=medium + + * Arch Linux is now supported by Propellor! + Thanks to Zihao Wang for this port. + * Added Propellor.Property.Pacman for Arch's package manager. + Maintained by Zihao Wang. + * The types of some properties changed; eg from Property DebianLike + to Property (DebianLike + ArchLinux). Also, DebianLike and Linux + are no longer type synonyms; propellor now knows that Linux includes + ArchLinux. This could require updates to code, so is a minor API change. + * GHC's fileSystemEncoding is used for all String IO, to avoid + encoding-related crashes in eg, Propellor.Property.File. + * Add --build option to simply build config.hs. + * More informative usage message. Thanks, Daniel Brooks + * Tor.hiddenService' added to support multiple ports. + Thanks, Félix Sipma. + * Apt.noPDiffs added. + Thanks, Sean Whitton. + * stack.yaml: Compile with GHC 8.0.1 against lts-7.16. + Thanks, Andrew Cowie. + * Added Propellor.Property.File.configFileName and related functions + to generate good filenames for config directories. + * Added Apt.suiteAvailablePinned, Apt.pinnedTo. + Thanks, Sean Whitton. + * Added File.containsBlock + Thanks, Sean Whitton. - -- amd64 Build Daemon (binet) <buildd-binet@buildd.debian.org> Tue, 22 Nov 2016 14:16:29 -0700 + -- Joey Hess <id@joeyh.name> Tue, 07 Feb 2017 12:09:24 -0400 propellor (3.2.3-1) unstable; urgency=medium @@ -386,7 +814,8 @@ propellor (3.0.0) unstable; urgency=medium a clone of propellor's git repository, or a minimal config, and will configure propellor to use a gpg key. * Stack support. "git config propellor.buildsystem stack" will make - propellor build its config using stack. + propellor build its config using stack. (This does not affect + how propellor is bootstrapped on a host by "propellor --spin host".) * When propellor is installed using stack, propellor --init will automatically set propellor.buildsystem=stack. diff --git a/debian/compat b/debian/compat @@ -1 +1 @@ -9 +10 diff --git a/debian/control b/debian/control @@ -4,7 +4,7 @@ Priority: optional Build-Depends: cabal-install, cdbs, - debhelper (>= 9), + debhelper (>= 10), ghc (>= 7.6), git, haskell-devscripts, @@ -16,16 +16,18 @@ Build-Depends: libghc-concurrent-output-prof, libghc-exceptions-dev (>= 0.6), libghc-exceptions-prof (>= 0.6), + libghc-hashable-dev, + libghc-hashable-prof, libghc-hslogger-dev, libghc-hslogger-prof, libghc-ifelse-dev, libghc-ifelse-prof, - libghc-missingh-dev, - libghc-missingh-prof, libghc-mtl-dev, libghc-mtl-prof, libghc-network-dev, libghc-network-prof, + libghc-split-dev, + libghc-split-prof, libghc-stm-dev, libghc-stm-prof, libghc-text-dev, @@ -35,10 +37,10 @@ Build-Depends: libghc-unix-compat-dev, libghc-unix-compat-prof, Maintainer: Sean Whitton <spwhitton@spwhitton.name> -Standards-Version: 3.9.8 +Standards-Version: 4.0.1 Homepage: https://propellor.branchable.com/ Vcs-Git: https://git.spwhitton.name/propellor -b debian -Vcs-Browser: https://git.spwhitton.name/?p=propellor.git;a=summary +Vcs-Browser: https://git.spwhitton.name/propellor X-Description: property-based host configuration management in haskell Propellor ensures that the system it's run in satisfies a list of properties, taking action as necessary when a property is not yet met. @@ -114,17 +116,17 @@ Depends: libghc-async-dev, libghc-concurrent-output-dev, libghc-exceptions-dev (>= 0.6), + libghc-hashable-dev, libghc-hslogger-dev, libghc-ifelse-dev, - libghc-missingh-dev, libghc-mtl-dev, libghc-network-dev, libghc-propellor-dev, + libghc-split-dev, libghc-stm-dev, libghc-text-dev, libghc-transformers-dev, libghc-unix-compat-dev, - make, ${misc:Depends}, ${shlibs:Depends}, Description: property-based host configuration management in haskell diff --git a/doc/README.mdwn b/doc/README.mdwn @@ -12,8 +12,8 @@ repository to each host it manages, in a [components](http://propellor.branchable.com/components/) for details. -Properties are defined using Haskell. Edit `~/.propellor/config.hs` -to get started. There is fairly complete +Properties are defined using Haskell in the file `~/.propellor/config.hs`. +There is fairly complete [API documentation](http://hackage.haskell.org/package/propellor/), which includes many built-in Properties for dealing with [Apt](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apt.html) @@ -41,6 +41,8 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask 1. Get propellor installed on your development machine (ie, laptop). `cabal install propellor` or + `stack install propellor` + or `apt-get install propellor` 2. Run `propellor --init` ; this will set up a `~/.propellor/` git repository for you. diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -4,6 +4,8 @@ module Main where import Propellor import Propellor.Property.Scheduled +import Propellor.Property.DiskImage +import Propellor.Property.Chroot import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network @@ -13,6 +15,7 @@ import qualified Propellor.Property.Cron as Cron import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User import qualified Propellor.Property.Hostname as Hostname +import qualified Propellor.Property.Fstab as Fstab import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Dns as Dns import qualified Propellor.Property.OpenId as OpenId @@ -25,7 +28,6 @@ import qualified Propellor.Property.Obnam as Obnam 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.Chroot as Chroot import qualified Propellor.Property.Fail2Ban as Fail2Ban import qualified Propellor.Property.Aiccu as Aiccu import qualified Propellor.Property.OS as OS @@ -36,7 +38,6 @@ import qualified Propellor.Property.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.Branchable as Branchable import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites -import Propellor.Property.DiskImage main :: IO () -- _ ______`| ,-.__ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' @@ -46,14 +47,15 @@ hosts :: [Host] -- * \ | | '--------' hosts = -- (o) ` [ darkstar , gnu + , dragon , clam - , mayfly - , oyster , orca + , baleen , honeybee , kite , elephant , beaver + , mouse , pell , keysafe ] ++ monsters @@ -69,7 +71,7 @@ testvm = host "testvm.kitenet.net" $ props & Apt.installed ["ssh"] & User.hasPassword (User "root") where - postinstall :: Property DebianLike + postinstall :: Property (HasInfo + DebianLike) postinstall = propertyList "fixing up after clean install" $ props & OS.preserveRootSshAuthorized & OS.preserveResolvConf @@ -79,41 +81,46 @@ testvm = host "testvm.kitenet.net" $ props darkstar :: Host darkstar = host "darkstar.kitenet.net" $ props + & osDebian Unstable X86_64 & ipv6 "2001:4830:1600:187::2" & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" - & Apt.buildDep ["git-annex"] `period` Daily + & User.nuked (User "nosuchuser") User.YesReallyDeleteHome & JoeySites.dkimMilter - & JoeySites.alarmClock "*-*-* 7:30" (User "joey") - "/usr/bin/timeout 45m /home/joey/bin/goodmorning" + & JoeySites.postfixSaslPasswordClient + -- & JoeySites.alarmClock "*-*-* 7:30" (User "joey") + -- "/usr/bin/timeout 45m /home/joey/bin/goodmorning" & 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 "/tmp/img" c MSDOS (grubBooted PC) + & imageBuilt "/srv/test.img" mychroot MSDOS [ partition EXT2 `mountedAt` "/boot" - `setFlag` BootFlag , partition EXT4 `mountedAt` "/" - `mountOpt` errorReadonly , swapPartition (MegaBytes 256) ] + `before` vmdkBuiltFor "/srv/test.img" where - c d = Chroot.debootstrapped mempty d $ props + mychroot d = debootstrapped mempty d $ props & osDebian Unstable X86_64 - & Hostname.setTo "demo" & Apt.installed ["linux-image-amd64"] - & User "root" `User.hasInsecurePassword` "root" + & Grub.installed PC gnu :: Host gnu = host "gnu.kitenet.net" $ props - & Apt.buildDep ["git-annex"] `period` Daily + & Postfix.satellite + +dragon :: Host +dragon = host "dragon.kitenet.net" $ props + & ipv6 "2001:4830:1600:187::2" + & JoeySites.dkimMilter + & JoeySites.postfixSaslPasswordClient clam :: Host clam = host "clam.kitenet.net" $ props & standardSystem Unstable X86_64 ["Unreliable server. Anything here may be lost at any time!" ] - & ipv4 "167.88.41.194" + & ipv4 "45.62.211.6" & CloudAtCost.decruft & Ssh.hostKeys hostContext @@ -122,65 +129,34 @@ clam = host "clam.kitenet.net" $ props , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBPhfvcOuw0Yt+MnsFc4TI2gWkKi62Eajxz+TgbHMO/uRTYF8c5V8fOI3o+J/3m5+lT0S5o8j8a7xIC3COvi+AVw=") ] & Apt.unattendedUpgrades - & Network.ipv6to4 & Systemd.persistentJournal - & Journald.systemMaxUse "500MiB" + & Journald.systemMaxUse "50MiB" & Tor.isRelay & Tor.named "kite1" & Tor.bandwidthRate (Tor.PerMonth "400 GB") - & Systemd.nspawned webserver - & File.dirExists "/var/www/html" - & File.notPresent "/var/www/index.html" - & "/var/www/html/index.html" `File.hasContent` ["hello, world"] - & alias "helloworld.kitenet.net" - & Systemd.nspawned oldusenetShellBox & JoeySites.scrollBox & alias "scroll.joeyh.name" & alias "us.scroll.joeyh.name" -mayfly :: Host -mayfly = host "mayfly.kitenet.net" $ props - & standardSystem (Stable "jessie") X86_64 - [ "Scratch VM. Contents can change at any time!" ] - & ipv4 "167.88.36.193" - - & CloudAtCost.decruft +baleen :: Host +baleen = host "baleen.kitenet.net" $ props + & standardSystem Unstable X86_64 [ "New git-annex build box." ] + + -- Not on public network; ssh access via bounce host. + & ipv4 "138.38.77.40" + + -- The root filesystem content may be lost if the VM is resized. + -- /dev/vdb contains persistent storage. + & Fstab.mounted "auto" "/dev/vdb" "/var/lib/container" mempty + & Apt.unattendedUpgrades - & Network.ipv6to4 - & Systemd.persistentJournal - & Journald.systemMaxUse "500MiB" - - & Tor.isRelay - & Tor.named "kite3" - & Tor.bandwidthRate (Tor.PerMonth "400 GB") - -oyster :: Host -oyster = host "oyster.kitenet.net" $ props - & standardSystem Unstable X86_64 - [ "Unreliable server. Anything here may be lost at any time!" ] - & ipv4 "64.137.221.146" - - & CloudAtCost.decruft - & Ssh.hostKeys hostContext - [ (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBP0ws/IxQegVU0RhqnIm5A/vRSPTO70wD4o2Bd1jL970dTetNyXzvWGe1spEbLjIYSLIO7WvOBSE5RhplBKFMUU=") - ] - & Apt.unattendedUpgrades - & Network.ipv6to4 + & Postfix.satellite + & Apt.serviceInstalledRunning "ntp" & Systemd.persistentJournal - & Journald.systemMaxUse "500MiB" - - & Tor.isRelay - & Tor.named "kite2" - & Tor.bandwidthRate (Tor.PerMonth "400 GB") - - -- Nothing is using http port 80, so listen on - -- that port for ssh, for traveling on bad networks that - -- block 22. - & Ssh.listenPort (Port 80) orca :: Host orca = host "orca.kitenet.net" $ props @@ -206,34 +182,46 @@ orca = host "orca.kitenet.net" $ props honeybee :: Host honeybee = host "honeybee.kitenet.net" $ props - & standardSystem Testing ARMHF [ "Arm git-annex build box." ] + & standardSystem Testing ARMHF + [ "Home router and arm git-annex build box." ] - -- I have to travel to get console access, so no automatic - -- upgrades, and try to be robust. + -- 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"] - & Network.dhcp "eth0" `requires` Network.cleanInterfacesFile - & Postfix.satellite + & 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" - -- ipv6 used for remote access thru firewalls - & Apt.serviceInstalledRunning "aiccu" - & ipv6 "2001:4830:1600:187::2" - -- restart to deal with failure to connect, tunnel issues, etc - & Cron.job "aiccu restart daily" Cron.Daily (User "root") "/" - "service aiccu stop; service aiccu start" - - -- In case compiler needs more than available ram - & Apt.serviceInstalledRunning "swapspace" - - -- No hardware clock. + -- No hardware clock & Apt.serviceInstalledRunning "ntp" + & JoeySites.homePowerMonitor + (User "joey") + (Context "homepower.joeyh.name") + (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIMAmVYddg/RgCbIj+cLcEiddeFXaYFnbEJ3uGj9G/EyV joey@honeybee") + & JoeySites.homeRouter + & Apt.installed ["mtr-tiny", "iftop", "screen"] + & Postfix.satellite + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer GitAnnexBuilder.armAutoBuilder - Unstable ARMEL Nothing Cron.Daily "22h") + 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") + -- 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" -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed @@ -242,7 +230,7 @@ kite :: Host kite = host "kite.kitenet.net" $ props & standardSystemUnhardened Testing X86_64 [ "Welcome to kite!" ] & ipv4 "66.228.36.95" - & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" + -- & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" & alias "kitenet.net" & alias "wren.kitenet.net" -- temporary & Ssh.hostKeys (Context "kitenet.net") @@ -252,7 +240,7 @@ kite = host "kite.kitenet.net" $ props , (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3") ] - & Network.static "eth0" `requires` Network.cleanInterfacesFile + & Network.preserveStatic "eth0" `requires` Network.cleanInterfacesFile & Apt.installed ["linux-image-amd64"] & Linode.serialGrub & Linode.mlocateEnabled @@ -262,6 +250,8 @@ kite = host "kite.kitenet.net" $ props & Journald.systemMaxUse "500MiB" & Ssh.passwordAuthentication True & Fail2Ban.installed -- since ssh password authentication is allowed + -- Allow ssh -R to forward ports via kite + & Ssh.setSshdConfig "GatewayPorts" "clientspecified" & Apt.serviceInstalledRunning "ntp" & "/etc/timezone" `File.hasContent` ["US/Eastern"] @@ -332,7 +322,10 @@ kite = host "kite.kitenet.net" $ props & JoeySites.oldUseNetServer hosts & alias "ns4.kitenet.net" - & myDnsPrimary True "kitenet.net" [] + & myDnsPrimary True "kitenet.net" + [ (RelDomain "mouse-onion", CNAME $ AbsDomain "htieo6yu2qtcn2j3.onion") + , (RelDomain "beaver-onion", CNAME $ AbsDomain "tl4xsvaxryjylgxs.onion") + ] & myDnsPrimary True "joeyh.name" [] & myDnsPrimary True "ikiwiki.info" [] & myDnsPrimary True "olduse.net" @@ -342,6 +335,10 @@ kite = host "kite.kitenet.net" $ props & branchableSecondary & Dns.secondaryFor ["animx"] hosts "animx.eu.org" + & alias "debug-me.joeyh.name" + -- debug-me installed manually until package is available + & Systemd.enabled "debug-me" + -- testing & Apache.httpsVirtualHost "letsencrypt.joeyh.name" "/var/www/html" (LetsEncrypt.AgreeTOS (Just "id@joeyh.name")) @@ -417,15 +414,23 @@ elephant = host "elephant.kitenet.net" $ props beaver :: Host beaver = host "beaver.kitenet.net" $ props & ipv6 "2001:4830:1600:195::2" - & Apt.serviceInstalledRunning "aiccu" & Apt.installed ["ssh"] & Ssh.hostPubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAACBAIrLX260fY0Jjj/p0syNhX8OyR8hcr6feDPGOj87bMad0k/w/taDSOzpXe0Wet7rvUTbxUjH+Q5wPd4R9zkaSDiR/tCb45OdG6JsaIkmqncwe8yrU+pqSRCxttwbcFe+UU+4AAcinjVedZjVRDj2rRaFPc9BXkPt7ffk8GwEJ31/AAAAFQCG/gOjObsr86vvldUZHCteaJttNQAAAIB5nomvcqOk/TD07DLaWKyG7gAcW5WnfY3WtnvLRAFk09aq1EuiJ6Yba99Zkb+bsxXv89FWjWDg/Z3Psa22JMyi0HEDVsOevy/1sEQ96AGH5ijLzFInfXAM7gaJKXASD7hPbVdjySbgRCdwu0dzmQWHtH+8i1CMVmA2/a5Y/wtlJAAAAIAUZj2US2D378jBwyX1Py7e4sJfea3WSGYZjn4DLlsLGsB88POuh32aOChd1yzF6r6C2sdoPBHQcWBgNGXcx4gF0B5UmyVHg3lIX2NVSG1ZmfuLNJs9iKNu4cHXUmqBbwFYQJBvB69EEtrOw4jSbiTKwHFmqdA/mw1VsMB+khUaVw==" + & Tor.installed + & Tor.hiddenServiceAvailable "ssh" (Port 22) & alias "usbackup.kitenet.net" & JoeySites.backupsBackedupFrom hosts "eubackup.kitenet.net" "/home/joey/lib/backup" & Apt.serviceInstalledRunning "anacron" & Cron.niceJob "system disk backed up" Cron.Weekly (User "root") "/" "rsync -a -x / /home/joey/lib/backup/beaver.kitenet.net/" +mouse :: Host +mouse = host "mouse.kitenet.net" $ props + & ipv4 "67.223.19.96" + & Apt.installed ["ssh"] + & Tor.installed + & Tor.hiddenServiceAvailable "ssh" (Port 22) + -- Branchable is not completely deployed with propellor yet. pell :: Host pell = host "pell.branchable.com" $ props @@ -448,6 +453,7 @@ pell = host "pell.branchable.com" $ props & alias "dist-bugs.kitenet.net" & alias "family.kitenet.net" + & osDebian (Stable "jessie") X86_64 & Apt.installed ["linux-image-amd64"] & Apt.unattendedUpgrades & Branchable.server hosts @@ -458,7 +464,7 @@ keysafe :: Host keysafe = host "keysafe.joeyh.name" $ props & ipv4 "139.59.17.168" & Hostname.sane - & osDebian (Stable "jessie") X86_64 + & osDebian (Stable "stretch") X86_64 & Apt.stdSourcesList `onChange` Apt.upgrade & Apt.unattendedUpgrades & DigitalOcean.distroKernel @@ -514,18 +520,11 @@ keysafe = host "keysafe.joeyh.name" $ props --------------------------- \____, o ,' ---------------------------- ---------------------------- '--,___________,' ----------------------------- --- Simple web server, publishing the outside host's /var/www -webserver :: Systemd.Container -webserver = Systemd.debContainer "webserver" $ props - & standardContainer (Stable "jessie") - & Systemd.bind "/var/www" - & Apache.installed - -- My own openid provider. Uses php, so containerized for security -- and administrative sanity. openidProvider :: Systemd.Container openidProvider = Systemd.debContainer "openid-provider" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & alias hn & OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8081)) where @@ -534,7 +533,7 @@ openidProvider = Systemd.debContainer "openid-provider" $ props -- Exhibit: kite's 90's website on port 1994. ancientKitenet :: Systemd.Container ancientKitenet = Systemd.debContainer "ancient-kitenet" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & alias hn & Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html" (Just "remotes/origin/old-kitenet.net") @@ -548,13 +547,13 @@ ancientKitenet = Systemd.debContainer "ancient-kitenet" $ props oldusenetShellBox :: Systemd.Container oldusenetShellBox = Systemd.debContainer "oldusenet-shellbox" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & alias "shell.olduse.net" & JoeySites.oldUseNetShellBox kiteShellBox :: Systemd.Container kiteShellBox = Systemd.debContainer "kiteshellbox" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & JoeySites.kiteShellBox type Motd = [String] @@ -633,14 +632,9 @@ monsters = -- but do want to track their public keys etc. & Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY=" , host "ns6.gandi.net" $ props & ipv4 "217.70.177.40" - , host "turtle.kitenet.net" $ props - & ipv4 "67.223.19.96" - & ipv6 "2001:4978:f:2d9::2" - , host "mouse.kitenet.net" $ props - & ipv6 "2001:4830:1600:492::2" , host "animx" $ props - & ipv4 "76.7.162.101" & ipv4 "76.7.162.186" + & ipv4 "76.7.162.187" ] diff --git a/propellor.cabal b/propellor.cabal @@ -1,6 +1,6 @@ Name: propellor -Version: 3.2.3 -Cabal-Version: >= 1.8 +Version: 4.7.7 +Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess @@ -36,46 +36,49 @@ Description: It is configured using haskell. Executable propellor + Default-Language: Haskell98 Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints - Extensions: TypeOperators + Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: -- propellor needs to support the ghc shipped in Debian stable, -- and also only depends on packages in Debian stable. base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Other-Modules: Propellor.DotDir Executable propellor-config - Main-Is: config.hs + Default-Language: Haskell98 + Main-Is: propellor-config.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints - Extensions: TypeOperators + Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Library + Default-Language: Haskell98 GHC-Options: -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints - Extensions: TypeOperators + Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Exposed-Modules: Propellor @@ -87,6 +90,7 @@ Library Propellor.Property.Apt Propellor.Property.Apt.PPA Propellor.Property.Attic + Propellor.Property.Bootstrap Propellor.Property.Borg Propellor.Property.Ccache Propellor.Property.Cmd @@ -110,6 +114,7 @@ Library Propellor.Property.FreeBSD Propellor.Property.FreeBSD.Pkg Propellor.Property.FreeBSD.Poudriere + Propellor.Property.FreeDesktop Propellor.Property.Fstab Propellor.Property.Git Propellor.Property.Gpg @@ -128,12 +133,15 @@ Library Propellor.Property.Obnam Propellor.Property.OpenId Propellor.Property.OS + Propellor.Property.Pacman Propellor.Property.Parted + Propellor.Property.Parted.Types Propellor.Property.Partition Propellor.Property.Postfix Propellor.Property.PropellorRepo Propellor.Property.Prosody Propellor.Property.Reboot + Propellor.Property.Restic Propellor.Property.Rsync Propellor.Property.Sbuild Propellor.Property.Scheduled @@ -143,10 +151,13 @@ Library Propellor.Property.Sudo Propellor.Property.Systemd Propellor.Property.Systemd.Core + Propellor.Property.Timezone Propellor.Property.Tor Propellor.Property.Unbound Propellor.Property.User Propellor.Property.Uwsgi + Propellor.Property.Versioned + Propellor.Property.XFCE Propellor.Property.ZFS Propellor.Property.ZFS.Process Propellor.Property.ZFS.Properties @@ -170,6 +181,8 @@ Library Propellor.EnsureProperty Propellor.Exception Propellor.Types + Propellor.Types.Bootloader + Propellor.Types.ConfigurableValue Propellor.Types.Core Propellor.Types.Chroot Propellor.Types.CmdLine @@ -181,6 +194,7 @@ Library Propellor.Types.Info Propellor.Types.MetaTypes Propellor.Types.OS + Propellor.Types.PartSpec Propellor.Types.PrivData Propellor.Types.Result Propellor.Types.ResultCheck @@ -218,10 +232,13 @@ Library Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled + Utility.Scheduled + Utility.Split Utility.SystemDirectory Utility.Table Utility.ThreadScheduler Utility.Tmp + Utility.Tuple Utility.UserInfo System.Console.Concurrent System.Console.Concurrent.Internal @@ -229,4 +246,4 @@ Library source-repository head type: git - location: git://git.joeyh.name/propellor.git + location: https://git.joeyh.name/git/propellor.git diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs @@ -1,8 +1,16 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module Propellor.Bootstrap ( + Bootstrapper(..), + Builder(..), + defaultBootstrapper, + getBootstrapper, bootstrapPropellorCommand, checkBinaryCommand, installGitCommand, buildPropellor, + checkDepsCommand, + buildCommand, ) where import Propellor.Base @@ -14,74 +22,124 @@ import Data.List type ShellCommand = String +-- | Different ways that Propellor's dependencies can be installed, +-- and propellor can be built. The default is `Robustly Cabal` +-- +-- `Robustly Cabal` and `Robustly Stack` use the OS's native packages +-- as much as possible to install Cabal, Stack, and propellor's build +-- dependencies. When necessary, dependencies are built from source +-- using Cabal or Stack rather than using the OS's native packages. +-- +-- `OSOnly` uses the OS's native packages of Cabal and all of propellor's +-- build dependencies. It may not work on all systems. +data Bootstrapper = Robustly Builder | OSOnly + deriving (Show, Typeable) + +data Builder = Cabal | Stack + deriving (Show, Typeable) + +defaultBootstrapper :: Bootstrapper +defaultBootstrapper = Robustly Cabal + +-- | Gets the Bootstrapper for the Host propellor is running on. +getBootstrapper :: Propellor Bootstrapper +getBootstrapper = go <$> askInfo + where + go NoInfoVal = defaultBootstrapper + go (InfoVal bs) = bs + +getBuilder :: Bootstrapper -> Builder +getBuilder (Robustly b) = b +getBuilder OSOnly = Cabal + -- Shell command line to ensure propellor is bootstrapped and ready to run. -- Should be run inside the propellor config dir, and will install -- all necessary build dependencies and build propellor. -bootstrapPropellorCommand :: Maybe System -> ShellCommand -bootstrapPropellorCommand msys = checkDepsCommand msys ++ +bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> ShellCommand +bootstrapPropellorCommand bs msys = checkDepsCommand bs msys ++ "&& if ! test -x ./propellor; then " - ++ buildCommand ++ - "; fi;" ++ checkBinaryCommand + ++ buildCommand bs ++ + "; fi;" ++ checkBinaryCommand bs -- Use propellor --check to detect if the local propellor binary has -- stopped working (eg due to library changes), and must be rebuilt. -checkBinaryCommand :: ShellCommand -checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi" +checkBinaryCommand :: Bootstrapper -> ShellCommand +checkBinaryCommand bs = "if test -x ./propellor && ! ./propellor --check; then " ++ go (getBuilder bs) ++ "; fi" where - go = intercalate " && " + go Cabal = intercalate " && " [ "cabal clean" - , buildCommand + , buildCommand bs + ] + go Stack = intercalate " && " + [ "stack clean" + , buildCommand bs ] -buildCommand :: ShellCommand -buildCommand = intercalate " && " - [ "cabal configure" - , "cabal build propellor-config" - , "ln -sf dist/build/propellor-config/propellor-config propellor" - ] +buildCommand :: Bootstrapper -> ShellCommand +buildCommand bs = intercalate " && " (go (getBuilder bs)) + where + go Cabal = + [ "cabal configure" + , "cabal build propellor-config" + , "ln -sf dist/build/propellor-config/propellor-config propellor" + ] + go Stack = + [ "stack build :propellor-config" + , "ln -sf $(stack path --dist-dir)/build/propellor-config/propellor-config propellor" + ] --- Run cabal configure to check if all dependencies are installed; --- if not, run the depsCommand. -checkDepsCommand :: Maybe System -> ShellCommand -checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi" +-- Check if all dependencies are installed; if not, run the depsCommand. +checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand +checkDepsCommand bs sys = go (getBuilder bs) + where + go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" + go Stack = "if ! stack build --dry-run >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" --- Install build dependencies of propellor. --- --- First, try to install ghc, cabal, gnupg, and all haskell libraries that --- propellor uses from OS packages. +-- Install build dependencies of propellor, using the specified +-- Bootstrapper. -- +-- When bootstrapping Robustly, first try to install the builder, +-- and all haskell libraries that propellor uses from OS packages. -- Some packages may not be available in some versions of Debian -- (eg, Debian wheezy lacks async), or propellor may need a newer version. --- So, as a second step, cabal is used to install all dependencies. +-- So, as a second step, any other dependencies are installed from source +-- using the builder. -- -- Note: May succeed and leave some deps not installed. -depsCommand :: Maybe System -> ShellCommand -depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true" +depsCommand :: Bootstrapper -> Maybe System -> ShellCommand +depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" where - osinstall = case msys of - Just (System (FreeBSD _) _) -> map pkginstall fbsddeps - Just (System (Debian _ _) _) -> useapt - Just (System (Buntish _) _) -> useapt - -- assume a debian derived system when not specified - Nothing -> useapt - - useapt = "apt-get update" : map aptinstall debdeps - - cabalinstall = + go (Robustly Cabal) = osinstall Cabal ++ [ "cabal update" , "cabal install --only-dependencies" + ] + go (Robustly Stack) = osinstall Stack ++ + [ "stack setup" + , "stack build --only-dependencies :propellor-config" ] + go OSOnly = osinstall Cabal + + osinstall builder = case msys of + Just (System (FreeBSD _) _) -> map pkginstall (fbsddeps builder) + Just (System (ArchLinux) _) -> map pacmaninstall (archlinuxdeps builder) + Just (System (Debian _ _) _) -> useapt builder + Just (System (Buntish _) _) -> useapt builder + -- assume a Debian derived system when not specified + Nothing -> useapt builder + + useapt builder = "apt-get update" : map aptinstall (debdeps builder) aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p + pacmaninstall p = "pacman -S --noconfirm --needed " ++ p -- This is the same deps listed in debian/control. - debdeps = + debdeps Cabal = [ "gnupg" , "ghc" , "cabal-install" , "libghc-async-dev" - , "libghc-missingh-dev" + , "libghc-split-dev" , "libghc-hslogger-dev" , "libghc-unix-compat-dev" , "libghc-ansi-terminal-dev" @@ -92,14 +150,19 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "libghc-exceptions-dev" , "libghc-stm-dev" , "libghc-text-dev" - , "make" + , "libghc-hashable-dev" + ] + debdeps Stack = + [ "gnupg" + , "haskell-stack" ] - fbsddeps = + + fbsddeps Cabal = [ "gnupg" , "ghc" , "hs-cabal-install" , "hs-async" - , "hs-MissingH" + , "hs-split" , "hs-hslogger" , "hs-unix-compat" , "hs-ansi-terminal" @@ -110,7 +173,35 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "hs-exceptions" , "hs-stm" , "hs-text" - , "gmake" + , "hs-hashable" + ] + fbsddeps Stack = + [ "gnupg" + , "stack" + ] + + archlinuxdeps Cabal = + [ "gnupg" + , "ghc" + , "cabal-install" + , "haskell-async" + , "haskell-split" + , "haskell-hslogger" + , "haskell-unix-compat" + , "haskell-ansi-terminal" + , "haskell-hackage-security" + , "haskell-ifelse" + , "haskell-network" + , "haskell-mtl" + , "haskell-transformers-base" + , "haskell-exceptions" + , "haskell-stm" + , "haskell-text" + , "hashell-hashable" + ] + archlinuxdeps Stack = + [ "gnupg" + , "stack" ] installGitCommand :: Maybe System -> ShellCommand @@ -121,31 +212,39 @@ installGitCommand msys = case msys of [ "ASSUME_ALWAYS_YES=yes pkg update" , "ASSUME_ALWAYS_YES=yes pkg install git" ] + (Just (System (ArchLinux) _)) -> use + [ "pacman -S --noconfirm --needed git"] -- assume a debian derived system when not specified Nothing -> use apt where - use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi" + use cmds = "if ! git --version >/dev/null 2>&1; then " ++ intercalate " && " cmds ++ "; fi" apt = [ "apt-get update" , "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" ] +-- Build propellor, and symlink the built binary to ./propellor. +-- +-- When the Host has a Buildsystem specified it is used. If none is +-- specified, look at git config propellor.buildsystem. buildPropellor :: Maybe Host -> IO () -buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $ +buildPropellor mh = unlessM (actionMessage "Propellor build" build) $ errorMessage "Propellor build failed!" where msys = case fmap (fromInfo . hostInfo) mh of Just (InfoVal sys) -> Just sys _ -> Nothing --- Build propellor using cabal or stack, and symlink propellor to the --- built binary. -build :: Maybe System -> IO Bool -build msys = catchBoolIO $ do - bs <- getGitConfigValue "propellor.buildsystem" - case bs of - Just "stack" -> stackBuild msys - _ -> cabalBuild msys + build = catchBoolIO $ do + case fromInfo (maybe mempty hostInfo mh) of + NoInfoVal -> do + bs <- getGitConfigValue "propellor.buildsystem" + case bs of + Just "stack" -> stackBuild msys + _ -> cabalBuild msys + InfoVal bs -> case getBuilder bs of + Cabal -> cabalBuild msys + Stack -> stackBuild msys -- For speed, only runs cabal configure when it's not been run before. -- If the build fails cabal may need to have configure re-run. @@ -178,7 +277,7 @@ cabalBuild msys = do , case msys of Nothing -> return False Just sys -> - boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))] + boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))] <&&> cabal ["configure"] ) cabal_build = cabal ["build", "propellor-config"] diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs @@ -19,26 +19,41 @@ import Propellor.Types.CmdLine import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim +import Utility.FileSystemEncoding usage :: Handle -> IO () usage h = hPutStrLn h $ unlines [ "Usage:" - , " propellor --init" - , " propellor" - , " propellor hostname" - , " propellor --spin targethost [--via relayhost]" - , " propellor --add-key keyid" - , " propellor --rm-key keyid" - , " propellor --list-fields" - , " propellor --dump field context" - , " propellor --edit field context" - , " propellor --set field context" - , " propellor --unset field context" - , " propellor --unset-unused" - , " propellor --merge" - , " propellor --build" - , " propellor --check" - ] + , " with no arguments, provision the current host" + , "" + , " --init" + , " initialize ~/.propellor" + , " hostname" + , " provision the current host as if it had the specified hostname" + , " --spin targethost [--via relayhost]" + , " provision the specified host" + , " --build" + , " recompile using your current config" + , " --add-key keyid" + , " add an additional signing key to the private data" + , " --rm-key keyid" + , " remove a signing key from the private data" + , " --list-fields" + , " list private data fields" + , " --set field context" + , " set a private data field" + , " --unset field context" + , " clear a private data field" + , " --unset-unused" + , " clear unused fields from the private data" + , " --dump field context" + , " show the content of a private data field" + , " --edit field context" + , " edit the content of a private data field" + , " --merge" + , " combine multiple spins into a single git commit" + , " --check" + , " double-check that propellor can actually run here"] usageError :: [String] -> IO a usageError ps = do @@ -54,6 +69,7 @@ processCmdLine = go =<< getArgs <$> mapM hostname (reverse hs) <*> pure (Just r) _ -> Spin <$> mapM hostname ps <*> pure Nothing + go ("--build":[]) = return Build go ("--add-key":k:[]) = return $ AddKey k go ("--rm-key":k:[]) = return $ RmKey k go ("--set":f:c:[]) = withprivfield f c Set @@ -94,6 +110,8 @@ data CanRebuild = CanRebuild | NoRebuild -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () defaultMain hostlist = withConcurrentOutput $ do + useFileSystemEncoding + setupGpgEnv Shim.cleanEnv checkDebugMode cmdline <- processCmdLine @@ -102,6 +120,7 @@ defaultMain hostlist = withConcurrentOutput $ do where go cr (Serialized cmdline) = go cr cmdline go _ Check = return () + go cr Build = buildFirst Nothing cr Build $ return () go _ (Set field context) = setPrivData field context go _ (Unset field context) = unsetPrivData field context go _ (UnsetUnused) = unsetPrivDataUnused hostlist @@ -186,7 +205,7 @@ updateFirst h canrebuild cmdline next = ifM hasOrigin , next ) --- If changes can be fetched from origin, Builds propellor (when allowed) +-- If changes can be fetched from origin, builds propellor (when allowed) -- and re-execs the updated propellor binary to continue. -- Otherwise, runs the IO action to continue. updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs @@ -51,15 +51,30 @@ propagateContainer ) => String -> c + -> (PropagateInfo -> Bool) -> Property metatypes -> Property metatypes -propagateContainer containername c prop = prop +propagateContainer containername c wanted prop = prop `addChildren` map convert (containerProperties c) where convert p = - let n = property (getDesc p) (getSatisfy p) :: Property UnixLike + let n = property'' (getDesc p) (getSatisfy p) :: Property UnixLike n' = n `setInfoProperty` mapInfo (forceHostContext containername) - (propagatableInfo (getInfo p)) + (propagatableInfo wanted (getInfo p)) `addChildren` map convert (getChildren p) in toChildProperty n' + +-- | Filters out parts of the Info that should not propagate out of a +-- container. +propagatableInfo :: (PropagateInfo -> Bool) -> Info -> Info +propagatableInfo wanted (Info l) = Info $ + filter (\(InfoEntry a) -> wanted (propagateInfo a)) l + +normalContainerInfo :: PropagateInfo -> Bool +normalContainerInfo PropagatePrivData = True +normalContainerInfo (PropagateInfo b) = b + +onlyPrivData :: PropagateInfo -> Bool +onlyPrivData PropagatePrivData = True +onlyPrivData (PropagateInfo _) = False diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs @@ -47,10 +47,10 @@ disthead = distdir </> "head" upstreambranch :: String upstreambranch = "upstream/master" --- Using the github mirror of the main propellor repo because +-- Using the joeyh.name mirror of the main propellor repo because -- it is accessible over https for better security. netrepo :: String -netrepo = "https://github.com/joeyh/propellor.git" +netrepo = "https://git.joeyh.name/git/propellor.git" dotPropellor :: IO FilePath dotPropellor = do @@ -316,7 +316,7 @@ minimalConfig = do ] stackResolver :: String -stackResolver = "lts-5.10" +stackResolver = "lts-8.22" fullClone :: IO Result fullClone = do diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs @@ -8,6 +8,8 @@ module Propellor.Engine ( fromHost, fromHost', onlyProcess, + chainPropellor, + runChainPropellor, ) where import System.Exit @@ -17,7 +19,9 @@ import "mtl" Control.Monad.RWS.Strict import System.PosixCompat import System.Posix.IO import System.FilePath +import System.Console.Concurrent import Control.Applicative +import Control.Concurrent.Async import Prelude import Propellor.Types @@ -28,6 +32,8 @@ import Propellor.Exception import Propellor.Info import Utility.Exception import Utility.Directory +import Utility.Process +import Utility.PartialPrelude -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. @@ -66,7 +72,9 @@ ensureChildProperties ps = ensure ps NoChange ensure [] rs = return rs ensure (p:ls) rs = do hn <- asks hostName - r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p) + r <- maybe (pure NoChange) + (actionMessageOn hn (getDesc p) . catchPropellor) + (getSatisfy p) ensure ls (r <> rs) -- | Lifts an action into the context of a different host. @@ -94,3 +102,53 @@ onlyProcess lockfile a = bracket lock unlock (const a) return l unlock = closeFd alreadyrunning = error "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. +chainPropellor :: CreateProcess -> IO Result +chainPropellor p = + -- We want to use outputConcurrent to display output + -- as it's received. If only stdout were captured, + -- concurrent-output would buffer all outputConcurrent. + -- Also capturing stderr avoids that problem. + withOEHandles createProcessSuccess p $ \(outh, errh) -> do + (r, ()) <- processChainOutput outh + `concurrently` forwardChainError errh + return r + +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing + where + go lastline = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> case lastline of + Nothing -> do + return FailedChange + Just l -> case readish l of + Just r -> pure r + Nothing -> do + outputConcurrent (l ++ "\n") + return FailedChange + Just s -> do + outputConcurrent $ + maybe "" (\l -> if null l then "" else l ++ "\n") lastline + go (Just s) + +forwardChainError :: Handle -> IO () +forwardChainError h = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> return () + Just s -> do + errorConcurrent (s ++ "\n") + forwardChainError h + +-- | Used by propellor sub-Processes that are run by chainPropellor. +runChainPropellor :: Host -> Propellor Result -> IO () +runChainPropellor h a = do + r <- runPropellor h a + flushConcurrentOutput + putStrLn $ "\n" ++ show r diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs @@ -46,7 +46,7 @@ ensureProperty => OuterMetaTypesWitness outer -> Property (MetaTypes inner) -> Propellor Result -ensureProperty _ = catchPropellor . getSatisfy +ensureProperty _ = maybe (return NoChange) catchPropellor . getSatisfy -- The name of this was chosen to make type errors a bit more understandable. type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool @@ -62,7 +62,7 @@ property' -> (OuterMetaTypesWitness metatypes -> Propellor Result) -> Property (MetaTypes metatypes) property' d a = - let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty + let p = Property sing d (Just (a (outerMetaTypesWitness p))) mempty mempty in p -- | Used to provide the metatypes of a Property to calls to diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs @@ -1,8 +1,9 @@ module Propellor.Gpg where import System.IO +import System.Posix.IO +import System.Posix.Terminal import Data.Maybe -import Data.List.Utils import Control.Monad import Control.Applicative import Prelude @@ -16,9 +17,32 @@ import Utility.Process.NonConcurrent import Utility.Monad import Utility.Misc import Utility.Tmp -import Utility.FileSystemEncoding import Utility.Env import Utility.Directory +import Utility.Split +import Utility.Exception + +-- | When at a tty, set GPG_TTY to point to the tty device. This is needed +-- so that when gpg is run with stio connected to a pipe, it is still able +-- to display password prompts at the console. +-- +-- This should not prevent gpg from using the GUI for prompting when one is +-- available. +setupGpgEnv :: IO () +setupGpgEnv = checkhandles [stdInput, stdOutput, stdError] + where + checkhandles [] = return () + checkhandles (h:hs) = do + isterm <- queryTerminal h + if isterm + then do + v <- tryNonAsync $ getTerminalName h + case v of + Right ttyname -> + -- do not overwrite + setEnv "GPG_TTY" ttyname False + Left _ -> checkhandles hs + else checkhandles hs type KeyId = String @@ -183,7 +207,7 @@ gpgDecrypt :: FilePath -> IO String gpgDecrypt f = do gpgbin <- getGpgBin ifM (doesFileExist f) - ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing (Just fileEncoding) + ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing Nothing , return "" ) @@ -201,6 +225,4 @@ gpgEncrypt f s = do encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing viaTmp writeFile f encrypted where - writer h = do - fileEncoding h - hPutStr h s + writer h = hPutStr h s diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs @@ -3,6 +3,7 @@ module Propellor.Info ( osDebian, osBuntish, + osArchLinux, osFreeBSD, setInfoProperty, addInfoProperty, @@ -83,13 +84,13 @@ askInfo = asks (fromInfo . hostInfo) -- It also lets the type checker know that all the properties of the -- host must support Debian. -- --- > & osDebian (Stable "jessie") X86_64 +-- > & osDebian (Stable "stretch") X86_64 osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian) osDebian = osDebian' Linux -- Use to specify a different `DebianKernel` than the default `Linux` -- --- > & osDebian' KFreeBSD (Stable "jessie") X86_64 +-- > & osDebian' KFreeBSD (Stable "stretch") X86_64 osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian) osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch) @@ -106,6 +107,10 @@ osBuntish release arch = tightenTargets $ os (System (Buntish release) arch) osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch) +-- | Specifies that a host's operating system is Arch Linux +osArchLinux :: Architecture -> Property (HasInfo + ArchLinux) +osArchLinux arch = tightenTargets $ os (System (ArchLinux) arch) + os :: System -> Property (HasInfo + UnixLike) os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system) diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs @@ -5,6 +5,8 @@ -- the messages will be displayed sequentially. module Propellor.Message ( + Trace(..), + parseTrace, getMessageHandle, isConsole, forceConsole, @@ -14,7 +16,6 @@ module Propellor.Message ( infoMessage, errorMessage, stopPropellorMessage, - processChainOutput, messagesDone, createProcessConcurrent, withConcurrentOutput, @@ -22,6 +23,7 @@ module Propellor.Message ( import System.Console.ANSI import System.IO +import Control.Monad.IfElse import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -31,12 +33,26 @@ import Prelude import Propellor.Types import Propellor.Types.Exception -import Utility.PartialPrelude import Utility.Monad +import Utility.Env import Utility.Exception +import Utility.PartialPrelude + +-- | Serializable tracing. Export `PROPELLOR_TRACE=1` in the environment to +-- make propellor emit these to stdout, in addition to its other output. +data Trace + = ActionStart (Maybe HostName) Desc + | ActionEnd (Maybe HostName) Desc Result + deriving (Read, Show) + +-- | Given a line read from propellor, if it's a serialized Trace, +-- parses it. +parseTrace :: String -> Maybe Trace +parseTrace = readish data MessageHandle = MessageHandle { isConsole :: Bool + , traceEnabled :: Bool } -- | A shared global variable for the MessageHandle. @@ -45,11 +61,16 @@ globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ newMVar =<< MessageHandle <$> catchDefaultIO False (hIsTerminalDevice stdout) + <*> ((== Just "1") <$> getEnv "PROPELLOR_TRACE") -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle +trace :: Trace -> IO () +trace t = whenM (traceEnabled <$> getMessageHandle) $ + putStrLn $ show t + -- | Force console output. This can be used when stdout is not directly -- connected to a console, but is eventually going to be displayed at a -- console. @@ -65,16 +86,17 @@ whenConsole s = ifM (isConsole <$> getMessageHandle) -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r +actionMessage :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing -- | Shows a message while performing an action on a specified host, -- with a colored status display. -actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' :: (MonadIO m, ActionResult r, ToResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do + liftIO $ trace $ ActionStart mhn desc liftIO $ outputConcurrent =<< whenConsole (setTitleCode $ "propellor: " ++ desc) @@ -88,6 +110,7 @@ actionMessage' mhn desc a = do , let (msg, intensity, color) = getActionResult r in colorLine intensity color msg ] + liftIO $ trace $ ActionEnd mhn desc (toResult r) return r where @@ -102,7 +125,7 @@ actionMessage' mhn desc a = do warningMessage :: MonadIO m => String -> m () warningMessage s = liftIO $ - outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) + errorConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) infoMessage :: MonadIO m => [String] -> m () infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls @@ -113,7 +136,7 @@ infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls -- property fail. Propellor will continue to the next property. errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do - outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) + errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s) -- Normally this exception gets caught and is not displayed, -- and propellor continues. So it's only displayed if not -- caught, and so we say, cannot continue. @@ -142,27 +165,6 @@ colorLine intensity color msg = concat <$> sequence , pure "\n" ] --- | Reads and displays each line from the Handle, except for the last line --- which is a Result. -processChainOutput :: Handle -> IO Result -processChainOutput h = go Nothing - where - go lastline = do - v <- catchMaybeIO (hGetLine h) - case v of - Nothing -> case lastline of - Nothing -> do - return FailedChange - Just l -> case readish l of - Just r -> pure r - Nothing -> do - outputConcurrent (l ++ "\n") - return FailedChange - Just s -> do - outputConcurrent $ - maybe "" (\l -> if null l then "" else l ++ "\n") lastline - go (Just s) - -- | Called when all messages about properties have been printed. messagesDone :: IO () messagesDone = outputConcurrent diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs @@ -57,7 +57,6 @@ import Utility.Misc import Utility.FileMode import Utility.Env import Utility.Table -import Utility.FileSystemEncoding import Utility.Directory -- | Allows a Property to access the value of a specific PrivDataField, @@ -171,7 +170,6 @@ getPrivData field context m = do setPrivData :: PrivDataField -> Context -> IO () setPrivData field context = do putStrLn "Enter private data on stdin; ctrl-D when done:" - fileEncoding stdin setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin unsetPrivData :: PrivDataField -> Context -> IO () @@ -274,7 +272,7 @@ readPrivData :: String -> PrivMap readPrivData = fromMaybe M.empty . readish readPrivDataFile :: FilePath -> IO PrivMap -readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f +readPrivDataFile f = readPrivData <$> readFileStrict f makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir @@ -283,10 +281,10 @@ newtype PrivInfo = PrivInfo { fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) } deriving (Eq, Ord, Show, Typeable, Monoid) --- PrivInfo is propagated out of containers, so that propellor can see which --- hosts need it. +-- PrivInfo always propagates out of containers, so that propellor +-- can see which hosts need it. instance IsInfo PrivInfo where - propagateInfo _ = True + propagateInfo _ = PropagatePrivData -- | Sets the context of any privdata that uses HostContext to the -- provided name. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs @@ -16,7 +16,6 @@ module Propellor.Property ( , check , fallback , revert - , applyToList -- * Property descriptions , describe , (==>) @@ -51,10 +50,10 @@ import Data.Monoid import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict import System.Posix.Files -import qualified Data.Hash.MD5 as MD5 +import Data.Maybe import Data.List +import Data.Hashable import Control.Applicative -import Data.Foldable hiding (and, elem) import Prelude import Propellor.Types @@ -66,8 +65,8 @@ import Propellor.Info import Propellor.EnsureProperty import Utility.Exception import Utility.Monad -import Utility.Misc import Utility.Directory +import Utility.Misc -- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- file to indicate whether it has run before. @@ -120,13 +119,15 @@ onChange -> CombinedType x y onChange = combineWith combiner revertcombiner where - combiner p hook = do + combiner (Just p) (Just hook) = Just $ do r <- p case r of MadeChange -> do r' <- hook return $ r <> r' _ -> return r + combiner (Just p) Nothing = Just p + combiner Nothing _ = Nothing revertcombiner = (<>) -- | Same as `onChange` except that if property y fails, a flag file @@ -144,24 +145,30 @@ onChangeFlagOnFail -> CombinedType x y onChangeFlagOnFail flagfile = combineWith combiner revertcombiner where - combiner s1 s2 = do + combiner (Just s1) s2 = Just $ do r1 <- s1 case r1 of MadeChange -> flagFailed s2 _ -> ifM (liftIO $ doesFileExist flagfile) - (flagFailed s2 + ( flagFailed s2 , return r1 ) + combiner Nothing _ = Nothing + revertcombiner = (<>) - flagFailed s = do + + flagFailed (Just s) = do r <- s liftIO $ case r of FailedChange -> createFlagFile _ -> removeFlagFile return r + flagFailed Nothing = return NoChange + createFlagFile = unlessM (doesFileExist flagfile) $ do createDirectoryIfMissing True (takeDirectory flagfile) writeFile flagfile "" + removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile -- | Changes the description of a property. @@ -178,11 +185,13 @@ infixl 1 ==> fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2 fallback = combineWith combiner revertcombiner where - combiner a1 a2 = do + combiner (Just a1) (Just a2) = Just $ do r <- a1 if r == FailedChange then a2 else return r + combiner (Just a1) Nothing = Just a1 + combiner Nothing _ = Nothing revertcombiner = (<>) -- | Indicates that a Property may change a particular file. When the file @@ -220,12 +229,12 @@ changesFile p f = checkResult getstat comparestat p -- Changes to mtime etc that do not change file content are treated as -- NoChange. changesFileContent :: Checkable p i => p i -> FilePath -> Property i -changesFileContent p f = checkResult getmd5 comparemd5 p +changesFileContent p f = checkResult gethash comparehash p where - getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f - comparemd5 oldmd5 = do - newmd5 <- getmd5 - return $ if oldmd5 == newmd5 then NoChange else MadeChange + gethash = catchMaybeIO $ hash <$> readFileStrict f + comparehash oldhash = do + newhash <- gethash + return $ if oldhash == newhash then NoChange else MadeChange -- | Determines if the first file is newer than the second file. -- @@ -263,7 +272,7 @@ isNewerThan x y = do -- -- For example: -- --- > upgraded :: UnixLike +-- > upgraded :: Property (DebianLike + FreeBSD) -- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded) -- > `describe` "OS upgraded" -- @@ -292,9 +301,9 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] -- are added as children, so their info will propigate. c = withOS (getDesc a) $ \_ o -> if matching o a - then getSatisfy a + then maybe (pure NoChange) id (getSatisfy a) else if matching o b - then getSatisfy b + then maybe (pure NoChange) id (getSatisfy b) else unsupportedOS' matching Nothing _ = False matching (Just o) p = @@ -308,8 +317,8 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] -- -- > myproperty :: Property Debian -- > myproperty = withOS "foo installed" $ \w o -> case o of --- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ... --- > (Just (System (Debian suite) arch)) -> ensureProperty w ... +-- > (Just (System (Debian kernel (Stable release)) arch)) -> ensureProperty w ... +-- > (Just (System (Debian kernel suite) arch)) -> ensureProperty w ... -- > _ -> unsupportedOS' -- -- Note that the operating system specifics may not be declared for all hosts, @@ -343,22 +352,17 @@ unsupportedOS' = go =<< getOS revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- | Apply a property to each element of a list. -applyToList - :: (Foldable t, Functor t, Combines p p, p ~ CombinedType p p) - => (b -> p) - -> t b - -> p -prop `applyToList` xs = Data.Foldable.foldr1 before $ prop <$> xs - makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange +-- | A no-op property. +-- +-- This is the same as `mempty` from the `Monoid` instance. doNothing :: SingI t => Property (MetaTypes t) -doNothing = property "noop property" noChange +doNothing = mempty -- | Registers an action that should be run at the very end, after -- propellor has checks all the properties of a host. diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs @@ -64,6 +64,24 @@ modEnabled modname = enable <!> disable `onChange` reloaded isenabled = boolSystem "a2query" [Param "-q", Param "-m", Param modname] +-- | Control whether an apache configuration file is enabled. +-- +-- The String is the base name of the configuration, eg "charset" or "gitweb". +confEnabled :: String -> RevertableProperty DebianLike DebianLike +confEnabled confname = enable <!> disable + where + enable = check (not <$> isenabled) + (cmdProperty "a2enconf" ["--quiet", confname]) + `describe` ("apache configuration enabled " ++ confname) + `requires` installed + `onChange` reloaded + disable = check isenabled + (cmdProperty "a2disconf" ["--quiet", confname]) + `describe` ("apache configuration disabled " ++ confname) + `requires` installed + `onChange` reloaded + isenabled = boolSystem "a2query" [Param "-q", Param "-c", Param confname] + -- | Make apache listen on the specified ports. -- -- Note that ports are also specified inside a site's config file, @@ -72,7 +90,7 @@ listenPorts :: [Port] -> Property DebianLike listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps `onChange` restarted where - portline port = "Listen " ++ fromPort port + portline port = "Listen " ++ val port -- This is a list of config files because different versions of apache -- use different filenames. Propellor simply writes them all. @@ -135,8 +153,8 @@ virtualHost domain port docroot = virtualHost' domain port docroot [] -- | Like `virtualHost` but with additional config lines added. virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike virtualHost' domain port docroot addedcfg = siteEnabled domain $ - [ "<VirtualHost *:" ++ fromPort port ++ ">" - , "ServerName " ++ domain ++ ":" ++ fromPort port + [ "<VirtualHost *:" ++ val port ++ ">" + , "ServerName " ++ domain ++ ":" ++ val port , "DocumentRoot " ++ docroot , "ErrorLog /var/log/apache2/error.log" , "LogLevel warn" @@ -171,7 +189,7 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown `requires` modEnabled "ssl" `before` setuphttps teardown = siteDisabled domain - setuphttp = siteEnabled' domain $ + setuphttp = (siteEnabled' domain $ -- The sslconffile is only created after letsencrypt gets -- the cert. The "*" is needed to make apache not error -- when the file doesn't exist. @@ -183,27 +201,27 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown , "RewriteRule ^/.well-known/(.*) - [L]" -- Everything else redirects to https , "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" - ] + ]) + `requires` File.dirExists (takeDirectory cf) setuphttps = LetsEncrypt.letsEncrypt letos domain docroot `onChange` postsetuphttps postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props - & File.dirExists (takeDirectory cf) & File.hasContent cf sslvhost `onChange` reloaded -- always reload since the cert has changed & reloaded where - cf = sslconffile "letsencrypt" sslvhost = vhost (Port 443) [ "SSLEngine on" , "SSLCertificateFile " ++ LetsEncrypt.certFile domain , "SSLCertificateKeyFile " ++ LetsEncrypt.privKeyFile domain , "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain ] + cf = sslconffile "letsencrypt" sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf" vhost p ls = - [ "<VirtualHost *:" ++ fromPort p ++">" - , "ServerName " ++ domain ++ ":" ++ fromPort p + [ "<VirtualHost *:" ++ val p ++">" + , "ServerName " ++ domain ++ ":" ++ val p , "DocumentRoot " ++ docroot , "ErrorLog /var/log/apache2/error.log" , "LogLevel warn" diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs @@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Propellor.Property.Apt where import Data.Maybe import Data.List +import Data.Typeable import System.IO import Control.Monad import Control.Applicative @@ -13,6 +15,40 @@ import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service import Propellor.Property.File (Line) +import Propellor.Types.Info + +data HostMirror = HostMirror Url + deriving (Eq, Show, Typeable) + +data HostAptProxy = HostAptProxy Url + deriving (Eq, Show, Typeable) + +-- | Indicate host's preferred apt mirror +mirror :: Url -> Property (HasInfo + UnixLike) +mirror u = pureInfoProperty (u ++ " apt mirror selected") + (InfoVal (HostMirror u)) + +getMirror :: Propellor Url +getMirror = do + mirrorInfo <- getMirrorInfo + osInfo <- getOS + return $ case (osInfo, mirrorInfo) of + (_, Just (HostMirror u)) -> u + (Just (System (Debian _ _) _), _) -> + "http://deb.debian.org/debian" + (Just (System (Buntish _) _), _) -> + "mirror://mirrors.ubuntu.com/" + (Just (System dist _), _) -> + error ("no Apt mirror defined for " ++ show dist) + _ -> error "no Apt mirror defined for this host or OS" + where + getMirrorInfo :: Propellor (Maybe HostMirror) + getMirrorInfo = fromInfoVal <$> askInfo + +withMirror :: Desc -> (Url -> Property DebianLike) -> Property DebianLike +withMirror desc mkp = property' desc $ \w -> do + u <- getMirror + ensureProperty w (mkp u) sourcesList :: FilePath sourcesList = "/etc/apt/sources.list" @@ -37,8 +73,8 @@ stableUpdatesSuite (Stable s) = Just (s ++ "-updates") stableUpdatesSuite _ = Nothing debLine :: String -> Url -> [Section] -> Line -debLine suite mirror sections = unwords $ - ["deb", mirror, suite] ++ sections +debLine suite url sections = unwords $ + ["deb", url, suite] ++ sections srcLine :: Line -> Line srcLine l = case words l of @@ -61,11 +97,8 @@ binandsrc url suite = catMaybes bs <- backportSuite suite return $ debLine bs url stdSections -debCdn :: SourcesGenerator -debCdn = binandsrc "http://httpredir.debian.org/debian" - -kernelOrg :: SourcesGenerator -kernelOrg = binandsrc "http://mirrors.kernel.org/debian" +stdArchiveLines :: Propellor SourcesGenerator +stdArchiveLines = return . binandsrc =<< getMirror -- | Only available for Stable and Testing securityUpdates :: SourcesGenerator @@ -75,11 +108,9 @@ securityUpdates suite in [l, srcLine l] | otherwise = [] --- | Makes sources.list have a standard content using the Debian mirror CDN, --- with the Debian suite configured by the os. --- --- Since the CDN is sometimes unreliable, also adds backup lines using --- kernel.org. +-- | Makes sources.list have a standard content using the Debian mirror CDN +-- (or other host specified using the `mirror` property), with the +-- Debian suite configured by the os. stdSourcesList :: Property Debian stdSourcesList = withOS "standard sources.list" $ \w o -> case o of (Just (System (Debian _ suite) _)) -> @@ -94,11 +125,62 @@ stdSourcesListFor suite = stdSourcesList' suite [] -- Note that if a Property needs to enable an apt source, it's better -- to do so via a separate file in </etc/apt/sources.list.d/> stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian -stdSourcesList' suite more = tightenTargets $ setSourcesList - (concatMap (\gen -> gen suite) generators) - `describe` ("standard sources.list for " ++ show suite) +stdSourcesList' suite more = tightenTargets $ + withMirror desc $ \u -> setSourcesList + (concatMap (\gen -> gen suite) (generators u)) where - generators = [debCdn, kernelOrg, securityUpdates] ++ more + generators u = [binandsrc u, securityUpdates] ++ more + desc = ("standard sources.list for " ++ show suite) + +type PinPriority = Int + +-- | Adds an apt source for a suite, and pins that suite to a given pin value +-- (see apt_preferences(5)). Revert to drop the source and unpin the suite. +-- +-- If the requested suite is the host's OS suite, the suite is pinned, but no +-- source is added. That apt source should already be available, or you can use +-- a property like 'Apt.stdSourcesList'. +suiteAvailablePinned + :: DebianSuite + -> PinPriority + -> RevertableProperty Debian Debian +suiteAvailablePinned s pin = available <!> unavailable + where + available :: Property Debian + available = tightenTargets $ combineProperties (desc True) $ props + & File.hasContent prefFile (suitePinBlock "*" s pin) + & setSourcesFile + + unavailable :: Property Debian + unavailable = tightenTargets $ combineProperties (desc False) $ props + & File.notPresent sourcesFile + `onChange` update + & File.notPresent prefFile + + setSourcesFile :: Property Debian + setSourcesFile = tightenTargets $ withMirror (desc True) $ \u -> + withOS (desc True) $ \w o -> case o of + (Just (System (Debian _ hostSuite) _)) + | s /= hostSuite -> ensureProperty w $ + File.hasContent sourcesFile (sources u) + `onChange` update + _ -> noChange + + -- Unless we are pinning a backports suite, filter out any backports + -- sources that were added by our generators. The user probably doesn't + -- want those to be pinned to the same value + sources u = dropBackports $ concatMap (\gen -> gen s) (generators u) + where + dropBackports + | "-backports" `isSuffixOf` (showSuite s) = id + | otherwise = filter (not . isInfixOf "-backports") + + generators u = [binandsrc u, securityUpdates] + prefFile = "/etc/apt/preferences.d/20" ++ showSuite s ++ ".pref" + sourcesFile = "/etc/apt/sources.list.d/" ++ showSuite s ++ ".list" + + desc True = "Debian " ++ showSuite s ++ " pinned, priority " ++ show pin + desc False = "Debian " ++ showSuite s ++ " not pinned" setSourcesList :: [Line] -> Property DebianLike setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update @@ -196,6 +278,50 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv where cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove" +-- | The name of a package, a glob to match the names of packages, or a regexp +-- surrounded by slashes to match the names of packages. See +-- apt_preferences(5), "Regular expressions and glob(7) syntax" +type AptPackagePref = String + +-- | Pins a list of packages, package wildcards and/or regular expressions to a +-- list of suites and corresponding pin priorities (see apt_preferences(5)). +-- Revert to unpin. +-- +-- Each package, package wildcard or regular expression will be pinned to all of +-- the specified suites. +-- +-- Note that this will have no effect unless there is an apt source for each of +-- the suites. One way to add an apt source is 'Apt.suiteAvailablePinned'. +-- +-- For example, to obtain Emacs Lisp addon packages not present in your release +-- of Debian from testing, falling back to sid if they're not available in +-- testing, you could use +-- +-- > & Apt.suiteAvailablePinned Testing (-10) +-- > & Apt.suiteAvailablePinned Unstable (-10) +-- > & ["elpa-*"] `Apt.pinnedTo` [(Testing, 100), (Unstable, 50)] +pinnedTo + :: [AptPackagePref] + -> [(DebianSuite, PinPriority)] + -> RevertableProperty Debian Debian +pinnedTo ps pins = mconcat (map (\p -> pinnedTo' p pins) ps) + `describe` unwords (("pinned to " ++ showSuites):ps) + where + showSuites = intercalate "," $ showSuite . fst <$> pins + +pinnedTo' + :: AptPackagePref + -> [(DebianSuite, PinPriority)] + -> RevertableProperty Debian Debian +pinnedTo' p pins = + (tightenTargets $ prefFile `File.hasContent` prefs) + <!> (tightenTargets $ File.notPresent prefFile) + where + prefs = foldr step [] pins + step (suite, pin) ls = ls ++ suitePinBlock p suite pin ++ [""] + prefFile = "/etc/apt/preferences.d/10propellor_" + ++ File.configFileName p <.> "pref" + -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. robustly :: Property DebianLike -> Property DebianLike @@ -349,5 +475,40 @@ hasForeignArch arch = check notAdded (add `before` update) add = cmdProperty "dpkg" ["--add-architecture", arch] `assume` MadeChange +-- | Disable the use of PDiffs for machines with high-bandwidth connections. +noPDiffs :: Property DebianLike +noPDiffs = tightenTargets $ "/etc/apt/apt.conf.d/20pdiffs" `File.hasContent` + [ "Acquire::PDiffs \"false\";" ] + +suitePin :: DebianSuite -> String +suitePin s = prefix s ++ showSuite s + where + prefix (Stable _) = "n=" + prefix _ = "a=" + +suitePinBlock :: AptPackagePref -> DebianSuite -> PinPriority -> [Line] +suitePinBlock p suite pin = + [ "Explanation: This file added by propellor" + , "Package: " ++ p + , "Pin: release " ++ suitePin suite + , "Pin-Priority: " ++ val pin + ] + dpkgStatus :: FilePath dpkgStatus = "/var/lib/dpkg/status" + +-- | Set apt's proxy +proxy :: Url -> Property (HasInfo + DebianLike) +proxy u = tightenTargets $ + proxyInfo `before` proxyConfig `describe` desc + where + proxyInfo = pureInfoProperty desc (InfoVal (HostAptProxy u)) + proxyConfig = "/etc/apt/apt.conf.d/20proxy" `File.hasContent` + [ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ] + desc = (u ++ " apt proxy selected") + +-- | Cause apt to proxy downloads via an apt cacher on localhost +useLocalCacher :: Property (HasInfo + DebianLike) +useLocalCacher = proxy "http://localhost:3142" + `requires` serviceInstalledRunning "apt-cacher-ng" + `describe` "apt uses local apt cacher" diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs @@ -6,10 +6,11 @@ module Propellor.Property.Apt.PPA where import Data.List import Control.Applicative import Prelude -import Data.String.Utils import Data.String (IsString(..)) + import Propellor.Base import qualified Propellor.Property.Apt as Apt +import Utility.Split -- | Ensure software-properties-common is installed. installed :: Property DebianLike @@ -25,8 +26,8 @@ data PPA = PPA , ppaArchive :: String -- ^ The name of the archive. } deriving (Eq, Ord) -instance Show PPA where - show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p] +instance ConfigurableValue PPA where + val p = concat ["ppa:", ppaAccount p, "/", ppaArchive p] instance IsString PPA where -- | Parse strings like "ppa:zfs-native/stable" into a PPA. @@ -40,9 +41,9 @@ instance IsString PPA where -- | Adds a PPA to the local system repositories. addPpa :: PPA -> Property DebianLike addPpa p = - cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv + cmdPropertyEnv "apt-add-repository" ["--yes", val p] Apt.noninteractiveEnv `assume` MadeChange - `describe` ("Added PPA " ++ (show p)) + `describe` ("Added PPA " ++ (val p)) `requires` installed -- | A repository key ID to be downloaded with apt-key. @@ -52,14 +53,11 @@ data AptKeyId = AptKeyId , akiServer :: String } deriving (Eq, Ord) -instance Show AptKeyId where - show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k] - -- | Adds an 'AptKeyId' from the specified GPG server. addKeyId :: AptKeyId -> Property DebianLike addKeyId keyId = check keyTrusted akcmd - `describe` (unwords ["Add third-party Apt key", show keyId]) + `describe` (unwords ["Add third-party Apt key", desc keyId]) where akcmd = tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId] @@ -72,10 +70,12 @@ addKeyId keyId = nkid = take 8 (akiId keyId) in (isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"] + desc k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k] -- | An Apt source line that apt-add-repository will just add to --- sources.list. It's also an instance of both 'Show' and 'IsString' to make --- using 'OverloadedStrings' in the configuration file easier. +-- sources.list. It's also an instance of both 'ConfigurableValue' +-- and 'IsString' to make using 'OverloadedStrings' in the configuration +-- file easier. -- -- | FIXME there's apparently an optional "options" fragment that I've -- definitely not parsed here. @@ -85,8 +85,8 @@ data AptSource = AptSource , asComponents :: [String] -- ^ The list of components to install from this repository. } deriving (Eq, Ord) -instance Show AptSource where - show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc] +instance ConfigurableValue AptSource where + val asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc] instance IsString AptSource where fromString s = @@ -103,7 +103,7 @@ addRepository :: AptRepository -> Property DebianLike addRepository (AptRepositoryPPA p) = addPpa p addRepository (AptRepositorySource src) = check repoExists addSrc - `describe` unwords ["Adding APT repository", show src] + `describe` unwords ["Adding APT repository", val src] `requires` installed where allSourceLines = @@ -112,4 +112,4 @@ addRepository (AptRepositorySource src) = . filter (not . isPrefixOf "#") . filter (/= "") . lines <$> allSourceLines repoExists = isInfixOf [src] <$> activeSources - addSrc = cmdProperty "apt-add-source" [show src] + addSrc = cmdProperty "apt-add-source" [val src] diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs @@ -1,8 +1,12 @@ -- | Maintainer: Félix Sipma <felix+propellor@gueux.org> -- -- Support for the Attic backup tool <https://attic-backup.org/> +-- +-- This module is deprecated because Attic is not available in debian +-- stable any longer (so the installed property no longer works), and it +-- appears to have been mostly supersceded by Borg. -module Propellor.Property.Attic +module Propellor.Property.Attic {-# DEPRECATED "Use Borg instead" #-} ( installed , repoExists , init @@ -131,11 +135,11 @@ backup' dir backupdir crontimes extraargs kp = cronjob -- passed to the `backup` property, they will run attic prune to clean out -- generations not specified here. keepParam :: KeepPolicy -> AtticParam -keepParam (KeepHours n) = "--keep-hourly=" ++ show n -keepParam (KeepDays n) = "--keep-daily=" ++ show n -keepParam (KeepWeeks n) = "--keep-daily=" ++ show n -keepParam (KeepMonths n) = "--keep-monthly=" ++ show n -keepParam (KeepYears n) = "--keep-yearly=" ++ show n +keepParam (KeepHours n) = "--keep-hourly=" ++ val n +keepParam (KeepDays n) = "--keep-daily=" ++ val n +keepParam (KeepWeeks n) = "--keep-daily=" ++ val n +keepParam (KeepMonths n) = "--keep-monthly=" ++ val n +keepParam (KeepYears n) = "--keep-yearly=" ++ val n -- | Policy for backup generations to keep. For example, KeepDays 30 will -- keep the latest backup for each day when a backup was made, and keep the diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs @@ -0,0 +1,144 @@ +-- | This module contains properties that configure how Propellor +-- bootstraps to run itself on a Host. + +module Propellor.Property.Bootstrap ( + Bootstrapper(..), + Builder(..), + bootstrapWith, + RepoSource(..), + bootstrappedFrom, + clonedFrom +) where + +import Propellor.Base +import Propellor.Bootstrap +import Propellor.Types.Info +import Propellor.Property.Chroot + +import Data.List +import qualified Data.ByteString as B + +-- | This property can be used to configure the `Bootstrapper` that is used +-- to bootstrap propellor on a Host. For example, if you want to use +-- stack: +-- +-- > host "example.com" $ props +-- > & bootstrapWith (Robustly Stack) +-- +-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`, +-- this property can also be added to the chroot to configure it. +bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike) +bootstrapWith b = pureInfoProperty desc (InfoVal b) + where + desc = "propellor bootstrapped with " ++ case b of + Robustly Stack -> "stack" + Robustly Cabal -> "cabal" + OSOnly -> "OS packages only" + +-- | Where a propellor repository should be bootstrapped from. +data RepoSource + = GitRepoUrl String + | GitRepoOutsideChroot + -- ^ When used in a chroot, this copies the git repository from + -- outside the chroot, including its configuration. + +-- | Bootstraps a propellor installation into +-- /usr/local/propellor/ +-- +-- Normally, propellor is bootstrapped by eg, using propellor --spin, +-- and so this property is not generally needed. +-- +-- This property only does anything when used inside a Chroot or other +-- Container. This is particularly useful inside a chroot used to build a +-- disk image, to make the disk image have propellor installed. +-- +-- The git repository is cloned (or pulled to update if it already exists). +-- +-- All build dependencies are installed, using distribution packages +-- or falling back to using cabal or stack. +bootstrappedFrom :: RepoSource -> Property Linux +bootstrappedFrom reposource = check inChroot $ + go `requires` clonedFrom reposource + where + go :: Property Linux + go = property "Propellor bootstrapped" $ do + system <- getOS + bootstrapper <- getBootstrapper + assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , checkDepsCommand bootstrapper system + , buildCommand bootstrapper + ] + +-- | Clones the propellor repository into /usr/local/propellor/ +-- +-- If the propellor repo has already been cloned, pulls to get it +-- up-to-date. +clonedFrom :: RepoSource -> Property Linux +clonedFrom reposource = case reposource of + GitRepoOutsideChroot -> go `onChange` copygitconfig + _ -> go + where + go :: Property Linux + go = property ("Propellor repo cloned from " ++ sourcedesc) $ + ifM needclone (makeclone, updateclone) + + makeclone = do + let tmpclone = localdir ++ ".tmpclone" + system <- getOS + assumeChange $ exposeTrueLocaldir $ \sysdir -> do + let originloc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> sysdir + runShellCommand $ buildShellCommand + [ installGitCommand system + , "rm -rf " ++ tmpclone + , "git clone " ++ shellEscape originloc ++ " " ++ tmpclone + , "mkdir -p " ++ localdir + -- This is done rather than deleting + -- the old localdir, because if it is bound + -- mounted from outside the chroot, deleting + -- it after unmounting in unshare will remove + -- the bind mount outside the unshare. + , "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)" + , "rm -rf " ++ tmpclone + ] + + updateclone = assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , "git pull" + ] + + -- Copy the git config of the repo outside the chroot into the + -- chroot. This way it has the same remote urls, and other git + -- configuration. + copygitconfig :: Property Linux + copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do + let gitconfig = localdir </> ".git" </> "config" + cfg <- liftIO $ B.readFile gitconfig + exposeTrueLocaldir $ const $ + liftIO $ B.writeFile gitconfig cfg + return MadeChange + + needclone = (inChroot <&&> truelocaldirisempty) + <||> (liftIO (not <$> doesDirectoryExist localdir)) + + truelocaldirisempty = exposeTrueLocaldir $ const $ + runShellCommand ("test ! -d " ++ localdir ++ "/.git") + + sourcedesc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> localdir ++ " outside the chroot" + +assumeChange :: Propellor Bool -> Propellor Result +assumeChange a = do + ok <- a + return (cmdResult ok <> MadeChange) + +buildShellCommand :: [String] -> String +buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") + +runShellCommand :: String -> Propellor Bool +runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s] diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs @@ -137,11 +137,11 @@ backup' dir backupdir crontimes extraargs kp = cronjob -- passed to the `backup` property, they will run borg prune to clean out -- generations not specified here. keepParam :: KeepPolicy -> BorgParam -keepParam (KeepHours n) = "--keep-hourly=" ++ show n -keepParam (KeepDays n) = "--keep-daily=" ++ show n -keepParam (KeepWeeks n) = "--keep-daily=" ++ show n -keepParam (KeepMonths n) = "--keep-monthly=" ++ show n -keepParam (KeepYears n) = "--keep-yearly=" ++ show n +keepParam (KeepHours n) = "--keep-hourly=" ++ val n +keepParam (KeepDays n) = "--keep-daily=" ++ val n +keepParam (KeepWeeks n) = "--keep-daily=" ++ val n +keepParam (KeepMonths n) = "--keep-monthly=" ++ val n +keepParam (KeepYears n) = "--keep-yearly=" ++ val n -- | Policy for backup generations to keep. For example, KeepDays 30 will -- keep the latest backup for each day when a backup was made, and keep the diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs @@ -76,7 +76,7 @@ limitToParams NoLimit = [] limitToParams (MaxSize s) = case maxSizeParam s of Just param -> [Right param] Nothing -> [Left $ "unable to parse data size " ++ s] -limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ show f] +limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ val f] limitToParams (l1 :+ l2) = limitToParams l1 <> limitToParams l2 -- | Configures a ccache in /var/cache for a group diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs @@ -4,12 +4,14 @@ module Propellor.Property.Chroot ( debootstrapped, bootstrapped, provisioned, + hostChroot, Chroot(..), ChrootBootstrapper(..), Debootstrapped(..), ChrootTarball(..), noServices, inChroot, + exposeTrueLocaldir, -- * Internal use provisioned', propagateChrootInfo, @@ -31,27 +33,28 @@ 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 -import Data.List.Utils import System.Posix.Directory -import System.Console.Concurrent -- | Specification of a chroot. Normally you'll use `debootstrapped` or --- `bootstrapped` to construct a Chroot value. +-- `bootstrapped` or `hostChroot` to construct a Chroot value. data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot + Chroot :: ChrootBootstrapper b => FilePath -> b -> InfoPropagator -> Host -> Chroot instance IsContainer Chroot where - containerProperties (Chroot _ _ h) = containerProperties h - containerInfo (Chroot _ _ h) = containerInfo h - setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) + containerProperties (Chroot _ _ _ h) = containerProperties h + containerInfo (Chroot _ _ _ h) = containerInfo h + setContainerProperties (Chroot loc b p h) ps = + let h' = setContainerProperties h ps + in Chroot loc b p h' chrootSystem :: Chroot -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo instance Show Chroot where - show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) + show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. @@ -93,6 +96,7 @@ instance ChrootBootstrapper Debootstrapped where buildchroot (Debootstrapped cf) system loc = case system of (Just s@(System (Debian _ _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s + (Just (System ArchLinux _)) -> Left "Arch Linux not supported by debootstrap." (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." Nothing -> Left "Cannot debootstrap; OS not specified" where @@ -114,7 +118,9 @@ debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot -bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps) +bootstrapped bootstrapper location ps = c + where + c = Chroot location bootstrapper propagateChrootInfo (host location ps) -- | Ensures that the chroot exists and is provisioned according to its -- properties. @@ -123,15 +129,14 @@ bootstrapped bootstrapper location ps = Chroot location bootstrapper (host locat -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux -provisioned c = provisioned' (propagateChrootInfo c) c False +provisioned c = provisioned' c False provisioned' - :: (Property Linux -> Property (HasInfo + Linux)) - -> Chroot + :: Chroot -> Bool -> RevertableProperty (HasInfo + Linux) Linux -provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = - (propigator $ setup `describe` chrootDesc c "exists") +provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly = + (infopropigator c normalContainerInfo $ setup `describe` chrootDesc c "exists") <!> (teardown `describe` chrootDesc c "removed") where @@ -150,17 +155,20 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = property ("removed " ++ loc) $ makeChange (removeChroot loc) -propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) -propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `setInfoProperty` chrootInfo c +type InfoPropagator = Chroot -> (PropagateInfo -> Bool) -> Property Linux -> Property (HasInfo + Linux) + +propagateChrootInfo :: InfoPropagator +propagateChrootInfo c@(Chroot location _ _ _) pinfo p = + propagateContainer location c pinfo $ + p `setInfoProperty` chrootInfo c chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ h) = mempty `addInfo` +chrootInfo (Chroot loc _ _ h) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike -propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir </> shimdir c let me = localdir </> "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -192,14 +200,12 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr , "--continue" , show cmd ] - let p' = p { env = Just pe } - r <- liftIO $ withHandle StdoutHandle createProcessSuccess p' - processChainOutput + r <- liftIO $ chainPropellor (p { env = Just pe }) liftIO cleanup return r toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _) systemdonly = do +toChain parenthost (Chroot loc _ _ _) systemdonly = do onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -214,17 +220,16 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = go h = do changeWorkingDirectory localdir when onconsole forceConsole - onlyProcess (provisioningLock loc) $ do - r <- runPropellor (setInChroot h) $ ensureChildProperties $ - if systemdonly - then [toChildProperty Systemd.installed] - else hostProperties h - flushConcurrentOutput - putStrLn $ "\n" ++ show r + onlyProcess (provisioningLock loc) $ + runChainPropellor (setInChroot h) $ + ensureChildProperties $ + if systemdonly + then [toChildProperty Systemd.installed] + else hostProperties h chain _ _ = errorMessage "bad chain command" inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do +inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -244,13 +249,13 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock" shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim" +shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc +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 @@ -286,3 +291,54 @@ setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) } newtype InChroot = InChroot Bool deriving (Typeable, Show) + +-- | Runs an action with the true localdir exposed, +-- not the one bind-mounted into a chroot. The action is passed the +-- path containing the contents of the localdir outside the chroot. +-- +-- In a chroot, this is accomplished by temporily bind mounting the localdir +-- to a temp directory, to preserve access to the original bind mount. Then +-- we unmount the localdir to expose the true localdir. Finally, to cleanup, +-- the temp directory is bind mounted back to the localdir. +exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a +exposeTrueLocaldir a = ifM inChroot + ( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> + bracket_ + (movebindmount localdir tmpdir) + (movebindmount tmpdir localdir) + (a tmpdir) + , a localdir + ) + where + movebindmount from to = liftIO $ do + run "mount" [Param "--bind", File from, File to] + -- Have to lazy unmount, because the propellor process + -- is running in the localdir that it's unmounting.. + run "umount" [Param "-l", File from] + -- We were in the old localdir; move to the new one after + -- flipping the bind mounts. Otherwise, commands that try + -- to access the cwd will fail because it got umounted out + -- from under. + changeWorkingDirectory "/" + changeWorkingDirectory localdir + run cmd ps = unlessM (boolSystem cmd ps) $ + error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps) + +-- | Generates a Chroot that has all the properties of a Host. +-- +-- Note that it's possible to create loops using this, where a host +-- contains a Chroot containing itself etc. Such loops will be detected at +-- runtime. +hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot +hostChroot h bootstrapper d = chroot + where + chroot = Chroot d bootstrapper pinfo h + pinfo = propagateHostChrootInfo h + +-- This is different than propagateChrootInfo in that Info using +-- HostContext is not made to use the name of the chroot as its context, +-- but instead uses the hostname of the Host. +propagateHostChrootInfo :: Host -> InfoPropagator +propagateHostChrootInfo h c pinfo p = + propagateContainer (hostName h) c pinfo $ + p `setInfoProperty` chrootInfo c diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs @@ -33,6 +33,7 @@ module Propellor.Property.Cmd ( Script, scriptProperty, userScriptProperty, + cmdResult, -- * Lower-level interface for running commands CommandParam(..), boolSystem, diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs @@ -64,10 +64,13 @@ concurrently p1 p2 = (combineWith go go p1 p2) -- Increase the number of capabilities right up to the number of -- processors, so that A `concurrently` B `concurrently` C -- runs all 3 properties on different processors when possible. - go a1 a2 = do + go (Just a1) (Just a2) = Just $ do n <- liftIO getNumProcessors withCapabilities n $ concurrentSatisfy a1 a2 + go (Just a1) Nothing = Just a1 + go Nothing (Just a2) = Just a2 + go Nothing Nothing = Nothing -- | Ensures all the properties in the list, with a specified amount of -- concurrency. @@ -101,9 +104,9 @@ concurrentList getn d (Props ps) = property d go `addChildren` ps Nothing -> return r Just p -> do hn <- asks hostName - r' <- actionMessageOn hn - (getDesc p) - (getSatisfy p) + r' <- case getSatisfy p of + Nothing -> return NoChange + Just a -> actionMessageOn hn (getDesc p) a worker q (r <> r') -- | Run an action with the number of capabiities increased as necessary to diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs @@ -323,15 +323,15 @@ instance Show NotConductorFor where show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l) instance IsInfo ConductorFor where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False instance IsInfo NotConductorFor where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False -- Added to Info when a host has been orchestrated. newtype Orchestrated = Orchestrated Any deriving (Typeable, Monoid, Show) instance IsInfo Orchestrated where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False isOrchestrated :: Orchestrated -> Bool isOrchestrated (Orchestrated v) = getAny v diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs @@ -9,8 +9,10 @@ module Propellor.Property.ConfFile ( IniSection, IniKey, containsIniSetting, + lacksIniSetting, hasIniSection, lacksIniSection, + iniFileContains, ) where import Propellor.Base @@ -92,6 +94,19 @@ containsIniSetting f (header, key, value) = adjustIniSection go (l:ls) = if isKeyVal l then confline : ls else l : go ls isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key] +-- | Removes a key=value setting from a section of an .ini file. +-- Note that the section heading is left in the file, so this is not a +-- perfect reversion of containsIniSetting. +lacksIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike +lacksIniSetting f (header, key, value) = adjustIniSection + (f ++ " section [" ++ header ++ "] lacks " ++ key ++ "=" ++ value) + header + (filter (/= confline)) + id + f + where + confline = key ++ "=" ++ value + -- | Ensures that a .ini file exists and contains a section -- with a given key=value list of settings. hasIniSection :: FilePath -> IniSection -> [(IniKey, String)] -> Property UnixLike @@ -114,3 +129,13 @@ lacksIniSection f header = adjustIniSection (const []) -- remove all lines of section id -- add no lines if section is missing f + +-- | Specifies the whole content of a .ini file. +-- +-- Revertijg this causes the file not to exist. +iniFileContains :: FilePath -> [(IniSection, [(IniKey, String)])] -> RevertableProperty UnixLike UnixLike +iniFileContains f l = f `hasContent` content <!> notPresent f + where + content = concatMap sectioncontent l + sectioncontent (section, keyvalues) = iniHeader section : + map (\(key, value) -> key ++ "=" ++ value) keyvalues diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs @@ -80,7 +80,8 @@ niceJob desc times user cddir command = job desc times user cddir -- | Installs a cron job to run propellor. runPropellor :: Times -> Property UnixLike -runPropellor times = withOS "propellor cron job" $ \w o -> +runPropellor times = withOS "propellor cron job" $ \w o -> do + bootstrapper <- getBootstrapper ensureProperty w $ niceJob "propellor" times (User "root") localdir - (bootstrapPropellorCommand o ++ "; ./propellor") + (bootstrapPropellorCommand bootstrapper o ++ "; ./propellor") diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs @@ -79,7 +79,7 @@ data DebianMirror = DebianMirror mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror mkDebianMirror dir crontimes = DebianMirror - { _debianMirrorHostName = "httpredir.debian.org" + { _debianMirrorHostName = "deb.debian.org" , _debianMirrorDir = dir , _debianMirrorSuites = [] , _debianMirrorArchitectures = [] diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs @@ -96,6 +96,7 @@ built' installprop target system@(System _ arch) config = extractSuite :: System -> Maybe String extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s extractSuite (System (Buntish r) _) = Just r +extractSuite (System (ArchLinux) _) = Nothing extractSuite (System (FreeBSD _) _) = Nothing -- | Ensures debootstrap is installed. @@ -148,7 +149,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do . filter ("debootstrap_" `isInfixOf`) . filter (".tar." `isInfixOf`) . extractUrls baseurl <$> - readFileStrictAnyEncoding indexfile + readFileStrict indexfile nukeFile indexfile tarfile <- case urls of diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs @@ -13,30 +13,30 @@ module Propellor.Property.DiskImage ( imageRebuilt, imageBuiltFrom, imageExists, - -- * Finalization - Finalization, - grubBooted, + vmdkBuiltFor, Grub.BIOS(..), - noFinalization, ) where import Propellor.Base import Propellor.Property.DiskImage.PartSpec 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.Grub as Grub import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import Propellor.Property.Parted -import Propellor.Property.Mount import Propellor.Property.Fstab (SwapPartition(..), genFstab) import Propellor.Property.Partition import Propellor.Property.Rsync +import Propellor.Types.Info +import Propellor.Types.Bootloader import Propellor.Container import Utility.Path +import Utility.FileMode -import Data.List (isPrefixOf, isInfixOf, sortBy) +import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4) import Data.Function (on) import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L @@ -49,30 +49,12 @@ type DiskImage = FilePath -- First the specified Chroot is set up, and its properties are satisfied. -- -- Then, the disk image is set up, and the chroot is copied into the --- appropriate partition(s) of it. --- --- Example use: --- --- > import Propellor.Property.DiskImage --- --- > let chroot d = Chroot.debootstrapped mempty d --- > & osDebian Unstable X86_64 --- > & Apt.installed ["linux-image-amd64"] --- > & User.hasPassword (User "root") --- > & User.accountFor (User "demo") --- > & User.hasPassword (User "demo") --- > & User.hasDesktopGroups (User "demo") --- > & ... --- > in imageBuilt "/srv/images/foo.img" chroot --- > MSDOS (grubBooted PC) --- > [ partition EXT2 `mountedAt` "/boot" --- > `setFlag` BootFlag --- > , partition EXT4 `mountedAt` "/" --- > `addFreeSpace` MegaBytes 100 --- > `mountOpt` errorReadonly --- > , swapPartition (MegaBytes 256) --- > ] +-- appropriate partition(s) of it. -- +-- The partitions default to being sized just large enough to fit the files +-- from the chroot. You can use `addFreeSpace` to make them a bit larger +-- than that, or `setSize` to use a fixed size. +-- -- Note that the disk image file is reused if it already exists, -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process. @@ -81,17 +63,65 @@ type DiskImage = FilePath -- 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. -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux +-- +-- Example use: +-- +-- > import Propellor.Property.DiskImage +-- > import Propellor.Property.Chroot +-- > +-- > foo = host "foo.example.com" $ props +-- > & imageBuilt "/srv/diskimages/disk.img" mychroot +-- > MSDOS +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 100 +-- > `mountOpt` errorReadonly +-- > , swapPartition (MegaBytes 256) +-- > ] +-- > where +-- > mychroot d = debootstrapped mempty d $ props +-- > & osDebian Unstable X86_64 +-- > & Apt.installed ["linux-image-amd64"] +-- > & Grub.installed PC +-- > & User.hasPassword (User "root") +-- > & User.accountFor (User "demo") +-- > & User.hasPassword (User "demo") +-- > & User.hasDesktopGroups (User "demo") +-- > & ... +-- +-- This can also be used with `Chroot.hostChroot` to build a disk image +-- that has all the properties of a Host. For example: +-- +-- > foo :: Host +-- > foo = host "foo.example.com" $ props +-- > & imageBuilt "/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) +-- > ] +-- > +-- > bar :: Host +-- > bar = host "bar.example.com" $ props +-- > & osDebian Unstable X86_64 +-- > & Apt.installed ["linux-image-amd64"] +-- > & Grub.installed PC +-- > & hasPassword (User "root") +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt = imageBuilt' 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 -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux -imageBuilt' rebuild img mkchroot tabletype final partspec = +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt' rebuild img mkchroot tabletype partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot `requires` (cleanrebuild <!> (doNothing :: Property UnixLike)) @@ -106,14 +136,21 @@ imageBuilt' rebuild img mkchroot tabletype final partspec = | otherwise = doNothing chrootdir = img ++ ".chroot" chroot = - let c = mkchroot chrootdir + let c = propprivdataonly $ mkchroot chrootdir in setContainerProps c $ containerProps c -- Before ensuring any other properties of the chroot, -- avoid starting services. Reverted by imageFinalized. &^ Chroot.noServices - -- First stage finalization. - & fst final & cachesCleaned + -- Only propagate privdata Info from this chroot, nothing else. + propprivdataonly (Chroot.Chroot d b ip h) = + Chroot.Chroot d b (\c _ -> ip c onlyPrivData) h + -- Pick boot loader finalization based on which bootloader is + -- installed. + final = case fromInfo (containerInfo chroot) of + [GrubInstalled] -> grubBooted + [] -> unbootable "no bootloader is installed" + _ -> unbootable "multiple bootloaders are installed; don't know which to use" -- | This property is automatically added to the chroot when building a -- disk image. It cleans any caches of information that can be omitted; @@ -124,13 +161,13 @@ cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) skipit = doNothing :: Property UnixLike -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg where desc = img ++ " built from " ++ chrootdir mkimg = property' desc $ \w -> do - -- unmount helper filesystems such as proc from the chroot - -- before getting sizes + -- Unmount helper filesystems such as proc from the chroot + -- first; don't want to include the contents of those. liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) @@ -139,18 +176,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts ensureProperty w $ - imageExists img (partTableSize parttable) - `before` - partitioned YesReallyDeleteDiskContents img parttable + imageExists' img parttable `before` kpartx img (mkimg' mnts mntopts parttable) mkimg' mnts mntopts parttable devs = partitionsPopulated chrootdir mnts mntopts devs `before` imageFinalized final mnts mntopts devs parttable - rmimg = File.notPresent img + rmimg = undoRevertableProperty (imageExists' img dummyparttable) + dummyparttable = PartTable tabletype [] -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> mconcat $ zipWith3 (go w) mnts mntopts devs where @@ -179,10 +215,10 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> -- The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) +fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) fitChrootSize tt l basesizes = (mounts, mountopts, parttable) where - (mounts, mountopts, sizers) = unzip3 l + (mounts, mountopts, sizers, _) = unzip4 l parttable = PartTable tt (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of @@ -220,7 +256,7 @@ getMountSz szm l (Just mntpt) = -- -- If the file is too large, truncates it down to the specified size. imageExists :: FilePath -> ByteSize -> Property Linux -imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do +imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img case ms of Just s @@ -231,21 +267,47 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do _ -> do L.writeFile img (L.replicate (fromIntegral sz) 0) return MadeChange + where + sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize + -- 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. + sectorsize = 4096 :: Double --- | A pair of properties. The first property is satisfied within the --- chroot, and is typically used to download the boot loader. +-- | Ensure that disk image file exists and is partitioned. -- --- The second property is run after the disk image is created, --- with its populated partition tree mounted in the provided --- location from the provided loop devices. This will typically --- take care of installing the boot loader to the image. +-- Avoids repartitioning the disk image, when a file of the right size +-- already exists, and it has the same PartTable. +imageExists' :: FilePath -> PartTable -> RevertableProperty DebianLike UnixLike +imageExists' img parttable = (setup <!> cleanup) `describe` desc + where + desc = "disk image exists " ++ img + parttablefile = img ++ ".parttable" + setup = property' desc $ \w -> do + oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile + res <- ensureProperty w $ imageExists img (partTableSize parttable) + if res == NoChange && oldparttable == show parttable + then return NoChange + else if res == FailedChange + then return FailedChange + else do + liftIO $ writeFile parttablefile (show parttable) + ensureProperty w $ partitioned YesReallyDeleteDiskContents img parttable + cleanup = File.notPresent img + `before` + File.notPresent parttablefile + +-- | A property that is run after the disk image is created, with +-- its populated partition tree mounted in the provided +-- location from the provided loop devices. This is typically used to +-- install a boot loader in the image's superblock. -- --- It's ok if the second property leaves additional things mounted +-- It's ok if the property leaves additional things mounted -- in the partition tree. -type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) +type Finalization = (FilePath -> [LoopDev] -> Property Linux) imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux -imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = +imageFinalized final mnts mntopts devs (PartTable _ parts) = property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> go w top `finally` liftIO (unmountall top) @@ -289,48 +351,27 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d") -noFinalization :: Finalization -noFinalization = (doNothing, \_ _ -> doNothing) +unbootable :: String -> Finalization +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. -grubBooted :: Grub.BIOS -> Finalization -grubBooted bios = (Grub.installed' bios, boots) +-- +-- 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 + `describe` "disk image boots using grub" where - boots mnt loopdevs = combineProperties "disk image boots using grub" $ props - -- bind mount host /dev so grub can access the loop devices - & 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 - -- work around for http://bugs.debian.org/802717 - & check haveosprober (inchroot "chmod" ["-x", osprober]) - & inchroot "update-grub" [] - `assume` MadeChange - & check haveosprober (inchroot "chmod" ["+x", osprober]) - & inchroot "grub-install" [wholediskloopdev] - `assume` MadeChange - -- sync all buffered changes out to the disk image - -- may not be necessary, but seemed needed sometimes - -- when using the disk image right away. - & cmdProperty "sync" [] - `assume` NoChange - where - -- cannot use </> since the filepath is absolute - inmnt f = mnt ++ f - - inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) - - haveosprober = doesFileExist (inmnt osprober) - osprober = "/etc/grub.d/30_os-prober" - - -- It doesn't matter which loopdev we use; all - -- come from the same disk image, and it's the loop dev - -- for the whole disk image we seek. - wholediskloopdev = case loopdevs of - (l:_) -> wholeDiskLoopDev l - [] -> error "No loop devs provided!" + -- It doesn't matter which loopdev we use; all + -- come from the same disk image, and it's the loop dev + -- for the whole disk image we seek. + wholediskloopdev = case loopdevs of + (l:_) -> wholeDiskLoopDev l + [] -> error "No loop devs provided!" isChild :: FilePath -> Maybe MountPoint -> Bool isChild mntpt (Just d) @@ -344,3 +385,20 @@ toSysDir :: FilePath -> FilePath -> FilePath toSysDir chrootdir d = case makeRelative chrootdir d of "." -> "/" sysdir -> "/" ++ sysdir + +-- | Builds a VirtualBox .vmdk file for the specified disk image file. +vmdkBuiltFor :: FilePath -> RevertableProperty DebianLike UnixLike +vmdkBuiltFor diskimage = (setup <!> cleanup) + `describe` (vmdkfile ++ " built") + where + vmdkfile = diskimage ++ ".vmdk" + setup = cmdProperty "VBoxManage" + [ "internalcommands", "createrawvmdk" + , "-filename", vmdkfile + , "-rawdisk", diskimage + ] + `changesFile` vmdkfile + `onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes)) + `requires` Apt.installed ["virtualbox"] + `requires` File.notPresent vmdkfile + cleanup = File.notPresent vmdkfile diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -1,32 +1,28 @@ -- | Disk image partition specification and combinators. +-- 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. + module Propellor.Property.DiskImage.PartSpec ( + module Propellor.Types.PartSpec, module Propellor.Property.DiskImage.PartSpec, - Partition, - PartSize(..), - PartFlag(..), - TableType(..), - Fs(..), - MountPoint, + module Propellor.Property.Parted.Types, + module Propellor.Property.Partition, ) where import Propellor.Base import Propellor.Property.Parted -import Propellor.Property.Mount +import Propellor.Types.PartSpec +import Propellor.Property.Parted.Types +import Propellor.Property.Partition (Fs(..)) --- | Specifies a mount point, mount options, and a constructor for a Partition. --- --- The size that is eventually provided is the amount of space needed 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. -type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition) - --- | Partitions that are not to be mounted (ie, LinuxSwap), or that have --- no corresponding directory in the chroot will have 128 MegaBytes --- provided as a default size. -defSz :: PartSize -defSz = MegaBytes 128 +-- | Adds additional free space to the 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. @@ -35,47 +31,3 @@ defSz = MegaBytes 128 -- Add an additional 200 mb for temp files, journals, etc. fudge :: PartSize -> PartSize fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) - --- | Specifies a swap partition of a given size. -swapPartition :: PartSize -> PartSpec -swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz)) - --- | Specifies a partition with a given filesystem. --- --- The partition is not mounted anywhere by default; use the combinators --- below to configure it. -partition :: Fs -> PartSpec -partition fs = (Nothing, mempty, mkPartition fs) - --- | Specifies where to mount a partition. -mountedAt :: PartSpec -> FilePath -> PartSpec -mountedAt (_, o, p) mp = (Just mp, o, p) - --- | Specifies a mount option, such as "noexec" -mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec -mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p) - --- | Mount option to make a partition be remounted readonly when there's an --- error accessing it. -errorReadonly :: MountOpts -errorReadonly = toMountOpts "errors=remount-ro" - --- | Adds additional free space to the partition. -addFreeSpace :: PartSpec -> PartSize -> PartSpec -addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz)) - --- | Forced a partition to be a specific size, instead of scaling to the --- size needed for the files in the chroot. -setSize :: PartSpec -> PartSize -> PartSpec -setSize (mp, o, p) sz = (mp, o, const (p sz)) - --- | Sets a flag on the partition. -setFlag :: PartSpec -> PartFlag -> PartSpec -setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } - --- | Makes a MSDOS partition be Extended, rather than Primary. -extended :: PartSpec -> PartSpec -extended s = adjustp s $ \p -> p { partType = Extended } - -adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec -adjustp (mp, o, p) f = (mp, o, f . p) diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs @@ -250,7 +250,7 @@ confStanza c = cfgline f v = "\t" ++ f ++ " " ++ v ++ ";" ipblock name l = [ "\t" ++ name ++ " {" ] ++ - (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++ + (map (\ip -> "\t\t" ++ val ip ++ ";") l) ++ [ "\t};" ] mastersblock | null (confMasters c) = [] @@ -307,17 +307,17 @@ rValue :: Record -> Maybe String rValue (Address (IPv4 addr)) = Just addr rValue (Address (IPv6 addr)) = Just addr rValue (CNAME d) = Just $ dValue d -rValue (MX pri d) = Just $ show pri ++ " " ++ dValue d +rValue (MX pri d) = Just $ val pri ++ " " ++ dValue d rValue (NS d) = Just $ dValue d rValue (SRV priority weight port target) = Just $ unwords - [ show priority - , show weight - , show port + [ val priority + , val weight + , val port , dValue target ] rValue (SSHFP x y s) = Just $ unwords - [ show x - , show y + [ val x + , val y , s ] rValue (INCLUDE f) = Just f diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs @@ -55,21 +55,22 @@ import Propellor.Container import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cmd as Cmd +import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Shim as Shim import Utility.Path import Utility.ThreadScheduler +import Utility.Split import Control.Concurrent.Async hiding (link) import System.Posix.Directory import System.Posix.Process import Prelude hiding (init) import Data.List hiding (init) -import Data.List.Utils import qualified Data.Map as M import System.Console.Concurrent -installed :: Property DebianLike -installed = Apt.installed ["docker.io"] +installed :: Property (DebianLike + ArchLinux) +installed = Apt.installed ["docker.io"] `pickOS` Pacman.installed ["docker"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. @@ -183,8 +184,9 @@ imagePulled ctr = pulled `describe` msg image = getImageName ctr propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) -propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ - p `addInfoProperty` dockerinfo +propagateContainerInfo ctr@(Container _ h) p = + propagateContainer cn ctr normalContainerInfo $ + p `addInfoProperty` dockerinfo where dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } @@ -322,7 +324,7 @@ class Publishable p where toPublish :: p -> String instance Publishable (Bound Port) where - toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p) + toPublish p = val (hostSide p) ++ ":" ++ val (containerSide p) -- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort instance Publishable String where @@ -574,8 +576,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d let p = inContainerProcess cid (if isConsole msgh then ["-it"] else []) (shim : params) - r <- withHandle StdoutHandle createProcessSuccess p $ - processChainOutput + r <- chainPropellor p when (r /= FailedChange) $ setProvisionedFlag cid return r @@ -594,10 +595,9 @@ chain hostlist hn s = case toContainerId s of where go cid h = do changeWorkingDirectory localdir - onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureChildProperties $ hostProperties h - flushConcurrentOutput - putStrLn $ "\n" ++ show r + onlyProcess (provisioningLock cid) $ + runChainPropellor h $ + ensureChildProperties $ hostProperties h stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] @@ -659,10 +659,10 @@ listImages :: IO [ImageUID] listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] runProp :: String -> RunParam -> Property (HasInfo + Linux) -runProp field val = tightenTargets $ pureInfoProperty (param) $ +runProp field v = tightenTargets $ pureInfoProperty (param) $ mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where - param = field++"="++val + param = field++"="++v genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux) genProp field mkval = tightenTargets $ pureInfoProperty field $ diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} module Propellor.Property.File where @@ -6,8 +6,10 @@ import Propellor.Base import Utility.FileMode import qualified Data.ByteString.Lazy as L +import Data.List (isInfixOf, isPrefixOf) import System.Posix.Files import System.Exit +import Data.Char type Line = String @@ -18,14 +20,42 @@ f `hasContent` newcontent = fileProperty (\_oldcontent -> newcontent) f -- | Ensures that a line is present in a file, adding it to the end if not. +-- +-- For example: +-- +-- > & "/etc/default/daemon.conf" `File.containsLine` ("cachesize = " ++ val 1024) +-- +-- The above example uses `val` to serialize a `ConfigurableValue` containsLine :: FilePath -> Line -> Property UnixLike f `containsLine` l = f `containsLines` [l] +-- | Ensures that a list of lines are present in a file, adding any that are not +-- to the end of the file. +-- +-- Note that this property does not guarantee that the lines will appear +-- consecutively, nor in the order specified. If you need either of these, use +-- 'File.containsBlock'. containsLines :: FilePath -> [Line] -> Property UnixLike f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f where go content = content ++ filter (`notElem` content) ls +-- | Ensures that a block of consecutive lines is present in a file, adding it +-- to the end if not. Revert to ensure that the block is not present (though +-- the lines it contains could be present, non-consecutively). +containsBlock :: FilePath -> [Line] -> RevertableProperty UnixLike UnixLike +f `containsBlock` ls = + fileProperty (f ++ " contains block:" ++ show ls) add f + <!> fileProperty (f ++ " lacks block:" ++ show ls) remove f + where + add content + | ls `isInfixOf` content = content + | otherwise = content ++ ls + remove [] = [] + remove content@(x:xs) + | ls `isPrefixOf` content = remove (drop (length ls) content) + | otherwise = x : remove xs + -- | Ensures that a line is not present in a file. -- Note that the file is ensured to exist, so if it doesn't, an empty -- file will be written. @@ -75,11 +105,11 @@ hasPrivContent' writemode source f context = -- | Replaces the content of a file with the transformed content of another file basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike -f `basedOn` (f', a) = property' desc $ \o -> do - tmpl <- liftIO $ readFile f' +f `basedOn` (src, a) = property' desc $ \o -> do + tmpl <- liftIO $ readFile src ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f where - desc = f ++ " is based on " ++ f' + desc = f ++ " is based on " ++ src -- | Removes a file. Does not remove symlinks or non-plain-files. notPresent :: FilePath -> Property UnixLike @@ -120,23 +150,26 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $ -- | Ensures that a file is a copy of another (regular) file. isCopyOf :: FilePath -> FilePath -> Property UnixLike -f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f') +f `isCopyOf` src = property desc $ go =<< (liftIO $ tryIO $ getFileStatus src) where - desc = f ++ " is copy of " ++ f' + desc = f ++ " is copy of " ++ src go (Right stat) = if isRegularFile stat - then gocmp =<< (liftIO $ cmp) - else warningMessage (f' ++ " is not a regular file") >> + then ifM (liftIO $ doesFileExist f) + ( gocmp =<< (liftIO $ cmp) + , doit + ) + else warningMessage (src ++ " is not a regular file") >> return FailedChange go (Left e) = warningMessage (show e) >> return FailedChange - cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f'] + cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File src] gocmp ExitSuccess = noChange gocmp (ExitFailure 1) = doit gocmp _ = warningMessage "cmp failed" >> return FailedChange - doit = makeChange $ copy f' `viaStableTmp` f - copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed" - runcp src dest = boolSystem "cp" + doit = makeChange $ copy `viaStableTmp` f + copy dest = unlessM (runcp dest) $ errorMessage "cp failed" + runcp dest = boolSystem "cp" [Param "--preserve=all", Param "--", File src, File dest] -- | Ensures that a file/dir has the specified owner and group. @@ -147,6 +180,20 @@ ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og) `changesFile` f og = owner ++ ":" ++ group +-- | Given a base directory, and a relative path under that +-- directory, applies a property to each component of the path in turn, +-- starting with the base directory. +-- +-- For example, to make a file owned by a user, making sure their home +-- directory and the subdirectories to it are also owned by them: +-- +-- > "/home/user/program/file" `hasContent` ["foo"] +-- > `before` applyPath "/home/user" ".config/program/file" +-- > (\f -> ownerGroup f (User "user") (Group "user")) +applyPath :: Monoid (Property metatypes) => FilePath -> FilePath -> (FilePath -> Property metatypes) -> Property metatypes +applyPath basedir relpath mkp = mconcat $ + map mkp (scanl (</>) basedir (splitPath relpath)) + -- | Ensures that a file/dir has the specfied mode. mode :: FilePath -> FileMode -> Property UnixLike mode f v = p `changesFile` f @@ -221,3 +268,51 @@ viaStableTmp a f = bracketIO setup cleanup go go tmpfile = do a tmpfile liftIO $ rename tmpfile f + +-- | Generates a base configuration file name from a String, which +-- can be put in a configuration directory, such as +-- </etc/apt/sources.list.d/> +-- +-- The generated file name is limited to using ASCII alphanumerics, +-- \'_\' and \'.\' , so that programs that only accept a limited set of +-- characters will accept it. Any other characters will be encoded +-- in escaped form. +-- +-- Some file extensions, such as ".old" may be filtered out by +-- programs that use configuration directories. To avoid such problems, +-- it's a good idea to add an static prefix and extension to the +-- result of this function. For example: +-- +-- > aptConf foo = "/etc/apt/apt.conf.d" </> "propellor_" ++ configFileName foo <.> ".conf" +configFileName :: String -> FilePath +configFileName = concatMap escape + where + escape c + | isAscii c && isAlphaNum c = [c] + | c == '.' = [c] + | otherwise = '_' : show (ord c) + +-- | Applies configFileName to any value that can be shown. +showConfigFileName :: Show v => v -> FilePath +showConfigFileName = configFileName . show + +-- | Inverse of showConfigFileName. +readConfigFileName :: Read v => FilePath -> Maybe v +readConfigFileName = readish . unescape + where + unescape [] = [] + unescape ('_':cs) = case break (not . isDigit) cs of + ([], _) -> '_' : unescape cs + (ns, cs') -> case readish ns of + Nothing -> '_' : ns ++ unescape cs' + Just n -> chr n : unescape cs' + unescape (c:cs) = c : unescape cs + +data Overwrite = OverwriteExisting | PreserveExisting + +-- | When passed PreserveExisting, only ensures the property when the file +-- does not exist. +checkOverwrite :: Overwrite -> FilePath -> (FilePath -> Property i) -> Property i +checkOverwrite OverwriteExisting f mkp = mkp f +checkOverwrite PreserveExisting f mkp = + check (not <$> doesFileExist f) (mkp f) diff --git a/src/Propellor/Property/Firejail.hs b/src/Propellor/Property/Firejail.hs @@ -22,7 +22,7 @@ installed = Apt.installed ["firejail"] -- -- See "DESKTOP INTEGRATION" in firejail(1). jailed :: [String] -> Property DebianLike -jailed ps = (jailed' `applyToList` ps) +jailed ps = mconcat (map jailed' ps) `requires` installed `describe` unwords ("firejail jailed":ps) diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs @@ -15,7 +15,6 @@ module Propellor.Property.Firewall ( TCPFlag(..), Frequency(..), IPWithMask(..), - fromIPWithMask ) where import Data.Monoid @@ -44,16 +43,16 @@ rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable toIpTable :: Rule -> [CommandParam] toIpTable r = map Param $ - fromChain (ruleChain r) : + val (ruleChain r) : toIpTableArg (ruleRules r) ++ - ["-t", fromTable (ruleTable r), "-j", fromTarget (ruleTarget r)] + ["-t", val (ruleTable r), "-j", val (ruleTarget r)] toIpTableArg :: Rules -> [String] toIpTableArg Everything = [] toIpTableArg (Proto proto) = ["-p", map toLower $ show proto] -toIpTableArg (DPort port) = ["--dport", fromPort port] +toIpTableArg (DPort port) = ["--dport", val port] toIpTableArg (DPortRange (portf, portt)) = - ["--dport", fromPort portf ++ ":" ++ fromPort portt] + ["--dport", val portf ++ ":" ++ val portt] toIpTableArg (InIFace iface) = ["-i", iface] toIpTableArg (OutIFace iface) = ["-o", iface] toIpTableArg (Ctstate states) = @@ -64,12 +63,12 @@ toIpTableArg (Ctstate states) = toIpTableArg (ICMPType i) = [ "-m" , "icmp" - , "--icmp-type", fromICMPTypeMatch i + , "--icmp-type", val i ] toIpTableArg (RateLimit f) = [ "-m" , "limit" - , "--limit", fromFrequency f + , "--limit", val f ] toIpTableArg (TCPFlags m c) = [ "-m" @@ -87,30 +86,30 @@ toIpTableArg (GroupOwner (Group g)) = ] toIpTableArg (Source ipwm) = [ "-s" - , intercalate "," (map fromIPWithMask ipwm) + , intercalate "," (map val ipwm) ] toIpTableArg (Destination ipwm) = [ "-d" - , intercalate "," (map fromIPWithMask ipwm) + , intercalate "," (map val ipwm) ] toIpTableArg (NotDestination ipwm) = [ "!" , "-d" - , intercalate "," (map fromIPWithMask ipwm) + , intercalate "," (map val ipwm) ] toIpTableArg (NatDestination ip mport) = [ "--to-destination" - , fromIPAddr ip ++ maybe "" (\p -> ":" ++ fromPort p) mport + , val ip ++ maybe "" (\p -> ":" ++ val p) mport ] toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r' data IPWithMask = IPWithNoMask IPAddr | IPWithIPMask IPAddr IPAddr | IPWithNumMask IPAddr Int deriving (Eq, Show) -fromIPWithMask :: IPWithMask -> String -fromIPWithMask (IPWithNoMask ip) = fromIPAddr ip -fromIPWithMask (IPWithIPMask ip ipm) = fromIPAddr ip ++ "/" ++ fromIPAddr ipm -fromIPWithMask (IPWithNumMask ip m) = fromIPAddr ip ++ "/" ++ show m +instance ConfigurableValue IPWithMask where + val (IPWithNoMask ip) = val ip + val (IPWithIPMask ip ipm) = val ip ++ "/" ++ val ipm + val (IPWithNumMask ip m) = val ip ++ "/" ++ val m data Rule = Rule { ruleChain :: Chain @@ -122,33 +121,33 @@ data Rule = Rule data Table = Filter | Nat | Mangle | Raw | Security deriving (Eq, Show) -fromTable :: Table -> String -fromTable Filter = "filter" -fromTable Nat = "nat" -fromTable Mangle = "mangle" -fromTable Raw = "raw" -fromTable Security = "security" +instance ConfigurableValue Table where + val Filter = "filter" + val Nat = "nat" + val Mangle = "mangle" + val Raw = "raw" + val Security = "security" data Target = ACCEPT | REJECT | DROP | LOG | TargetCustom String deriving (Eq, Show) -fromTarget :: Target -> String -fromTarget ACCEPT = "ACCEPT" -fromTarget REJECT = "REJECT" -fromTarget DROP = "DROP" -fromTarget LOG = "LOG" -fromTarget (TargetCustom t) = t +instance ConfigurableValue Target where + val ACCEPT = "ACCEPT" + val REJECT = "REJECT" + val DROP = "DROP" + val LOG = "LOG" + val (TargetCustom t) = t data Chain = INPUT | OUTPUT | FORWARD | PREROUTING | POSTROUTING | ChainCustom String deriving (Eq, Show) -fromChain :: Chain -> String -fromChain INPUT = "INPUT" -fromChain OUTPUT = "OUTPUT" -fromChain FORWARD = "FORWARD" -fromChain PREROUTING = "PREROUTING" -fromChain POSTROUTING = "POSTROUTING" -fromChain (ChainCustom c) = c +instance ConfigurableValue Chain where + val INPUT = "INPUT" + val OUTPUT = "OUTPUT" + val FORWARD = "FORWARD" + val PREROUTING = "PREROUTING" + val POSTROUTING = "POSTROUTING" + val (ChainCustom c) = c data Proto = TCP | UDP | ICMP deriving (Eq, Show) @@ -159,15 +158,15 @@ data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int deriving (Eq, Show) -fromICMPTypeMatch :: ICMPTypeMatch -> String -fromICMPTypeMatch (ICMPTypeName t) = t -fromICMPTypeMatch (ICMPTypeCode c) = show c +instance ConfigurableValue ICMPTypeMatch where + val (ICMPTypeName t) = t + val (ICMPTypeCode c) = val c data Frequency = NumBySecond Int deriving (Eq, Show) -fromFrequency :: Frequency -> String -fromFrequency (NumBySecond n) = show n ++ "/second" +instance ConfigurableValue Frequency where + val (NumBySecond n) = val n ++ "/second" type TCPFlagMask = [TCPFlag] diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -39,7 +39,7 @@ pkgCmd cmd args = newtype PkgUpdate = PkgUpdate String deriving (Typeable, Monoid, Show) instance IsInfo PkgUpdate where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False pkgUpdated :: PkgUpdate -> Bool pkgUpdated (PkgUpdate _) = True @@ -55,8 +55,9 @@ update = newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) + instance IsInfo PkgUpgrade where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False pkgUpgraded :: PkgUpgrade -> Bool pkgUpgraded (PkgUpgrade _) = True diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs @@ -19,8 +19,9 @@ poudriereConfigPath = "/usr/local/etc/poudriere.conf" newtype PoudriereConfigured = PoudriereConfigured String deriving (Typeable, Monoid, Show) + instance IsInfo PoudriereConfigured where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False poudriereConfigured :: PoudriereConfigured -> Bool poudriereConfigured (PoudriereConfigured _) = True @@ -68,7 +69,7 @@ jail j@(Jail name version arch) = tightenTargets $ nx <- liftIO $ not <$> jailExists j return $ c && nx - (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version] + (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", val arch, "-v", val version] createJail = cmdProperty cmd args in check chk createJail @@ -101,9 +102,10 @@ data PoudriereZFS = PoudriereZFS ZFS.ZFS ZFS.ZFSProperties data Jail = Jail String FBSDVersion PoudriereArch data PoudriereArch = I386 | AMD64 deriving (Eq) -instance Show PoudriereArch where - show I386 = "i386" - show AMD64 = "amd64" + +instance ConfigurableValue PoudriereArch where + val I386 = "i386" + val AMD64 = "amd64" fromArchitecture :: Architecture -> PoudriereArch fromArchitecture X86_64 = AMD64 @@ -127,7 +129,7 @@ instance ToShellConfigLines PoudriereZFS where toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) = [ ("NO_ZFS", "no") , ("ZPOOL", pool) - , ("ZROOTFS", show dataset) + , ("ZROOTFS", val dataset) ] type ConfigLine = String diff --git a/src/Propellor/Property/FreeDesktop.hs b/src/Propellor/Property/FreeDesktop.hs @@ -0,0 +1,29 @@ +-- | Freedesktop.org configuration file properties. + +module Propellor.Property.FreeDesktop where + +import Propellor.Base +import Propellor.Property.ConfFile + +desktopFile :: String -> FilePath +desktopFile s = s ++ ".desktop" + +-- | Name used in a desktop file; user visible. +type Name = String + +-- | Command that a dekstop file runs. May include parameters. +type Exec = String + +-- | Specifies an autostart file. By default it will be located in the +-- system-wide autostart directory. +autostart :: FilePath -> Name -> Exec -> RevertableProperty UnixLike UnixLike +autostart f n e = ("/etc/xdg/autostart" </> f) `iniFileContains` + [ ("Desktop Entry", + [ ("Type", "Application") + , ("Version", "1.0") + , ("Name", n) + , ("Comment", "Autostart") + , ("Terminal", "False") + , ("Exec", e) + ] ) + ] diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs @@ -24,19 +24,32 @@ import Utility.Table -- Note that if anything else is already mounted at the `MountPoint`, it -- will be left as-is by this property. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux -mounted fs src mnt opts = tightenTargets $ - "/etc/fstab" `File.containsLine` l - `describe` (mnt ++ " mounted by fstab") +mounted fs src mnt opts = tightenTargets $ + listed fs src mnt opts `onChange` mountnow where - l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] - dump = "0" - passno = "2" -- This use of mountPoints, which is linux-only, is why this -- property currently only supports linux. mountnow = check (notElem mnt <$> mountPoints) $ cmdProperty "mount" [mnt] +-- | Ensures that </etc/fstab> contains a line mounting the specified +-- `Source` on the specified `MountPoint`. Does not ensure that it's +-- currently `mounted`. +listed :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike +listed fs src mnt opts = "/etc/fstab" `File.containsLine` l + `describe` (mnt ++ " mounted by fstab") + where + l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] + dump = "0" + passno = "2" + +-- | Ensures that </etc/fstab> contains a line enabling the specified +-- `Source` to be used as swap space, and that it's enabled. +swap :: Source -> Property Linux +swap src = listed "swap" src "none" mempty + `onChange` swapOn src + newtype SwapPartition = SwapPartition FilePath -- | Replaces </etc/fstab> with a file that should cause the currently @@ -77,8 +90,8 @@ genFstab mnts swaps mnttransform = do , pure "0" , pure (if mnt == "/" then "1" else "2") ] - getswapcfg (SwapPartition swap) = sequence - [ fromMaybe swap <$> getM (\a -> a swap) + getswapcfg (SwapPartition s) = sequence + [ fromMaybe s <$> getM (\a -> a s) [ uuidprefix getSourceUUID , sourceprefix getSourceLabel ] diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs @@ -2,7 +2,6 @@ module Propellor.Property.Gpg where import Propellor.Base import qualified Propellor.Property.Apt as Apt -import Utility.FileSystemEncoding import System.PosixCompat @@ -35,7 +34,6 @@ keyImported key@(GpgKeyId keyid) user@(User u) = prop ( return NoChange , makeChange $ withHandle StdinHandle createProcessSuccess (proc "su" ["-c", "gpg --import", u]) $ \h -> do - fileEncoding h hPutStr h (unlines keylines) hClose h ) diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs @@ -3,6 +3,10 @@ module Propellor.Property.Grub where import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt +import Propellor.Property.Mount +import Propellor.Property.Chroot (inChroot) +import Propellor.Types.Info +import Propellor.Types.Bootloader -- | Eg, \"hd0,0\" or \"xen/xvda1\" type GrubDevice = String @@ -18,9 +22,10 @@ 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. -installed :: BIOS -> Property DebianLike -installed bios = installed' bios `onChange` mkConfig +-- This includes running update-grub, unless it's run in a chroot. +installed :: BIOS -> Property (HasInfo + DebianLike) +installed bios = installed' bios + `onChange` (check (not <$> inChroot) mkConfig) -- Run update-grub, to generate the grub boot menu. It will be -- automatically updated when kernel packages are installed. @@ -29,11 +34,11 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property Linux -installed' bios = (aptinstall `pickOS` unsupportedOS) +installed' :: BIOS -> Property (HasInfo + DebianLike) +installed' bios = setInfoProperty aptinstall + (toInfo [GrubInstalled]) `describe` "grub package installed" where - aptinstall :: Property DebianLike aptinstall = Apt.installed [debpkg] debpkg = case bios of PC -> "grub-pc" @@ -64,12 +69,12 @@ boots dev = tightenTargets $ cmdProperty "grub-install" [dev] -- -- The rootdev should be in the form "hd0", while the bootdev is in the form -- "xen/xvda". -chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property (HasInfo + DebianLike) chainPVGrub rootdev bootdev timeout = combineProperties desc $ props & File.dirExists "/boot/grub" & "/boot/grub/menu.lst" `File.hasContent` [ "default 1" - , "timeout " ++ show timeout + , "timeout " ++ val timeout , "" , "title grub-xen shim" , "root (" ++ rootdev ++ ")" @@ -85,3 +90,54 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc $ props xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"] `assume` MadeChange `describe` "/boot-xen-shim" + +-- | This is a version of `boots` that makes grub boot the system mounted +-- 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 + -- remove mounts that are done below to make sure the right thing + -- gets mounted + & cleanupmounts + -- bind mount host /dev so grub can access the loop devices + & 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 + -- work around for http://bugs.debian.org/802717 + & check haveosprober (inchroot "chmod" ["-x", osprober]) + & inchroot "update-grub" [] + `assume` MadeChange + & check haveosprober (inchroot "chmod" ["+x", osprober]) + & inchroot "grub-install" [wholediskdev] + `assume` MadeChange + & cleanupmounts + -- sync all buffered changes out to the disk in case it's + -- used right away + & cmdProperty "sync" [] + `assume` NoChange + where + desc = "grub boots " ++ wholediskdev + + -- cannot use </> since the filepath is absolute + inmnt f = mnt ++ f + + inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) + + haveosprober = doesFileExist (inmnt osprober) + osprober = "/etc/grub.d/30_os-prober" + + 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/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs @@ -8,7 +8,7 @@ import Utility.FileMode -- | Configures grub to use the serial console as set up by Linode. -- Useful when running a distribution supplied kernel. -- <https://www.linode.com/docs/tools-reference/custom-kernels-distros/run-a-distribution-supplied-kernel-with-kvm> -serialGrub :: Property DebianLike +serialGrub :: Property (HasInfo + DebianLike) serialGrub = "/etc/default/grub" `File.containsLines` [ "GRUB_CMDLINE_LINUX=\"console=ttyS0,19200n8\"" , "GRUB_DISABLE_LINUX_UUID=true" @@ -17,11 +17,12 @@ serialGrub = "/etc/default/grub" `File.containsLines` ] `onChange` Grub.mkConfig `requires` Grub.installed Grub.PC + `describe` "GRUB configured for Linode serial console" -- | Linode's pv-grub-x86_64 (only used for its older XEN instances) -- does not support booting recent Debian kernels compressed -- with xz. This sets up pv-grub chaining to enable it. -chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike +chainPVGrub :: Grub.TimeoutSecs -> Property (HasInfo + DebianLike) chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" -- | Linode disables mlocate's cron job's execute permissions, diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs @@ -3,9 +3,9 @@ module Propellor.Property.Hostname where import Propellor.Base import qualified Propellor.Property.File as File import Propellor.Property.Chroot (inChroot) +import Utility.Split import Data.List -import Data.List.Utils -- | Ensures that the hostname is set using best practices, to whatever -- name the `Host` has. diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs @@ -10,7 +10,12 @@ installed :: Property DebianLike installed = Apt.installed ["lightdm"] -- | Configures LightDM to skip the login screen and autologin as a user. -autoLogin :: User -> Property UnixLike -autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting` - ("SeatDefaults", "autologin-user", u) - `describe` "lightdm autologin" +autoLogin :: User -> RevertableProperty DebianLike DebianLike +autoLogin (User u) = (setup <!> cleanup) + `describe` ("lightdm autologin for " ++ u) + where + cf = "/etc/lightdm/lightdm.conf" + setting = ("Seat:*", "autologin-user", u) + setup = cf `ConfFile.containsIniSetting` setting + `requires` installed + cleanup = tightenTargets $ cf `ConfFile.lacksIniSetting` setting diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs @@ -43,6 +43,13 @@ propertyList desc (Props ps) = -- | Combines a list of properties, resulting in one property that -- ensures each in turn. Stops if a property fails. +-- +-- > combineProperties "foo" $ props +-- > & bar +-- > & baz +-- +-- This is similar to using `mconcat` with a list of properties, +-- except it can combine together different types of properties. combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) @@ -53,7 +60,7 @@ combineProperties desc (Props ps) = combineSatisfy :: [ChildProperty] -> Result -> Propellor Result combineSatisfy [] rs = return rs combineSatisfy (p:ps) rs = do - r <- catchPropellor $ getSatisfy p + r <- maybe (return NoChange) catchPropellor (getSatisfy p) case r of FailedChange -> return FailedChange _ -> combineSatisfy ps (r <> rs) diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs @@ -4,6 +4,7 @@ module Propellor.Property.Locale where import Propellor.Base import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt import Data.List (isPrefixOf) @@ -50,7 +51,8 @@ locale `isSelectedFor` vars = do -- Per Debian bug #684134 we cannot ensure a locale is generated by means of -- Apt.reConfigure. So localeAvailable edits /etc/locale.gen manually. available :: Locale -> RevertableProperty DebianLike DebianLike -available locale = ensureAvailable <!> ensureUnavailable +available locale = ensureAvailable `requires` Apt.installed ["locales"] + <!> ensureUnavailable where f = "/etc/locale.gen" desc = (locale ++ " locale generated") @@ -61,7 +63,7 @@ available locale = ensureAvailable <!> ensureUnavailable then ensureProperty w $ fileProperty desc (foldr uncomment []) f `onChange` regenerate - else return FailedChange -- locale unavailable for generation + else error $ "locale " ++ locale ++ " is not present in /etc/locale.gen, even in commented out form; cannot generate" ensureUnavailable :: Property DebianLike ensureUnavailable = tightenTargets $ fileProperty (locale ++ " locale not generated") (foldr comment []) f diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs @@ -16,21 +16,21 @@ import qualified Propellor.Property.File as File data ReportLevel = Workstation | Server | Paranoid type Service = String -instance Show ReportLevel where - show Workstation = "workstation" - show Server = "server" - show Paranoid = "paranoid" +instance ConfigurableValue ReportLevel where + val Workstation = "workstation" + val Server = "server" + val Paranoid = "paranoid" -- The common prefix used by default in syslog lines. defaultPrefix :: String defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ " ignoreFilePath :: ReportLevel -> Service -> FilePath -ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n +ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (val t) </> n ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls - `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")") + `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ val t ++ ")") installed :: Property DebianLike installed = Apt.installed ["logcheck"] diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs @@ -40,6 +40,9 @@ formatMountOpts (MountOpts []) = "defaults" formatMountOpts (MountOpts l) = intercalate "," l -- | Mounts a device, without listing it in </etc/fstab>. +-- +-- Note that this property will fail if the device is already mounted +-- at the MountPoint. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike mounted fs src mnt opts = property (mnt ++ " mounted") $ toResult <$> liftIO (mount fs src mnt opts) @@ -52,6 +55,17 @@ bindMount src dest = tightenTargets $ `assume` MadeChange `describe` ("bind mounted " ++ src ++ " to " ++ dest) +-- | Enables swapping to a device, which must be formatted already as a swap +-- partition. +swapOn :: Source -> RevertableProperty Linux Linux +swapOn mnt = tightenTargets doswapon <!> tightenTargets doswapoff + where + swaps = lines <$> readProcess "swapon" ["--show=NAME"] + doswapon = check (notElem mnt <$> swaps) $ + cmdProperty "swapon" [mnt] + doswapoff = check (elem mnt <$> swaps) $ + cmdProperty "swapoff" [mnt] + mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool mount fs src mnt opts = boolSystem "mount" $ [ Param "-t", Param fs @@ -64,6 +78,10 @@ mount fs src mnt opts = boolSystem "mount" $ mountPoints :: IO [MountPoint] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] +-- | Checks if anything is mounted at the MountPoint. +isMounted :: MountPoint -> IO Bool +isMounted mnt = isJust <$> getFsType mnt + -- | Finds all filesystems mounted inside the specified directory. mountPointsBelow :: FilePath -> IO [MountPoint] mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target) @@ -115,12 +133,15 @@ blkidTag tag dev = catchDefaultIO Nothing $ -- | Unmounts a device or mountpoint, -- lazily so any running processes don't block it. +-- +-- Note that this will fail if it's not mounted. umountLazy :: FilePath -> IO () umountLazy mnt = unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ stopPropellorMessage $ "failed unmounting " ++ mnt --- | Unmounts anything mounted inside the specified directory. +-- | Unmounts anything mounted inside the specified directory, +-- not including the directory itself. unmountBelow :: FilePath -> IO () unmountBelow d = do submnts <- mountPointsBelow d diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs @@ -7,6 +7,9 @@ import Data.Char type Interface = String +-- | Options to put in a stanza of an ifupdown interfaces file. +type InterfaceOptions = [(String, String)] + ifUp :: Interface -> Property DebianLike ifUp iface = tightenTargets $ cmdProperty "ifup" [iface] `assume` MadeChange @@ -19,27 +22,57 @@ ifUp iface = tightenTargets $ cmdProperty "ifup" [iface] -- -- No interfaces are brought up or down by this property. cleanInterfacesFile :: Property DebianLike -cleanInterfacesFile = tightenTargets $ hasContent interfacesFile - [ "# Deployed by propellor, do not edit." - , "" - , "source-directory interfaces.d" +cleanInterfacesFile = interfaceFileContains interfacesFile + [ "source-directory interfaces.d" , "" , "# The loopback network interface" , "auto lo" , "iface lo inet loopback" ] + [] `describe` ("clean " ++ interfacesFile) -- | Configures an interface to get its address via dhcp. dhcp :: Interface -> Property DebianLike -dhcp iface = tightenTargets $ hasContent (interfaceDFile iface) +dhcp iface = dhcp' iface mempty + +dhcp' :: Interface -> InterfaceOptions -> Property DebianLike +dhcp' iface options = interfaceFileContains (interfaceDFile iface) [ "auto " ++ iface , "iface " ++ iface ++ " inet dhcp" - ] + ] options `describe` ("dhcp " ++ iface) `requires` interfacesDEnabled --- | Writes a static interface file for the specified interface. +newtype Gateway = Gateway IPAddr + +-- | Configures an interface with a static address and gateway. +static :: Interface -> IPAddr -> Maybe Gateway -> Property DebianLike +static iface addr gateway = static' iface addr gateway mempty + +static' :: Interface -> IPAddr -> Maybe Gateway -> InterfaceOptions -> Property DebianLike +static' iface addr gateway options = + interfaceFileContains (interfaceDFile iface) headerlines options' + `describe` ("static IP address for " ++ iface) + `requires` interfacesDEnabled + where + headerlines = + [ "auto " ++ iface + , "iface " ++ iface ++ " " ++ inet ++ " static" + ] + options' = catMaybes + [ Just $ ("address", val addr) + , case gateway of + Just (Gateway gaddr) -> + Just ("gateway", val gaddr) + Nothing -> Nothing + ] ++ options + inet = case addr of + IPv4 _ -> "inet" + IPv6 _ -> "inet6" + +-- | Writes a static interface file for the specified interface +-- to preserve its current configuration. -- -- The interface has to be up already. It could have been brought up by -- DHCP, or by other means. The current ipv4 addresses @@ -50,8 +83,8 @@ dhcp iface = tightenTargets $ hasContent (interfaceDFile iface) -- -- (ipv6 addresses are not included because it's assumed they come up -- automatically in most situations.) -static :: Interface -> Property DebianLike -static iface = tightenTargets $ +preserveStatic :: Interface -> Property DebianLike +preserveStatic iface = tightenTargets $ check (not <$> doesFileExist f) setup `describe` desc `requires` interfacesDEnabled @@ -84,13 +117,13 @@ static iface = tightenTargets $ -- | 6to4 ipv6 connection, should work anywhere ipv6to4 :: Property DebianLike -ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0") - [ "# Deployed by propellor, do not edit." +ipv6to4 = tightenTargets $ interfaceFileContains (interfaceDFile "sit0") + [ "auto sit0" , "iface sit0 inet6 static" - , "\taddress 2002:5044:5531::1" - , "\tnetmask 64" - , "\tgateway ::192.88.99.1" - , "auto sit0" + ] + [ ("address", "2002:5044:5531::1") + , ("netmask", "64") + , ("gateway", "::192.88.99.1") ] `describe` "ipv6to4" `requires` interfacesDEnabled @@ -114,3 +147,10 @@ interfacesDEnabled :: Property DebianLike interfacesDEnabled = tightenTargets $ containsLine interfacesFile "source-directory interfaces.d" `describe` "interfaces.d directory enabled" + +interfaceFileContains :: FilePath -> [String] -> InterfaceOptions -> Property DebianLike +interfaceFileContains f headerlines options = tightenTargets $ hasContent f $ + warning : headerlines ++ map fmt options + where + fmt (k, v) = "\t" ++ k ++ " " ++ v + warning = "# Deployed by propellor, do not edit." diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs @@ -64,7 +64,7 @@ import Control.Exception (throw) -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here -cleanInstallOnce :: Confirmation -> Property Linux +cleanInstallOnce :: Confirmation -> Property DebianLike cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ go `requires` confirmed "clean install confirmed" confirmation where @@ -207,7 +207,7 @@ preserveNetwork = go `requires` Network.cleanInterfacesFile ["route", "list", "scope", "global"] case words <$> headMaybe ls of Just ("default":"via":_:"dev":iface:_) -> - ensureProperty w $ Network.static iface + ensureProperty w $ Network.preserveStatic iface _ -> do warningMessage "did not find any default ipv4 route" return FailedChange diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs @@ -1,6 +1,9 @@ -- | Support for the Obnam backup tool <http://obnam.org/> +-- +-- This module is deprecated because Obnam has been retired by its +-- author. -module Propellor.Property.Obnam where +module Propellor.Property.Obnam {-# DEPRECATED "Obnam has been retired; time to transition to something else" #-} where import Propellor.Base import qualified Propellor.Property.Apt as Apt @@ -150,7 +153,7 @@ keepParam ps = "--keep=" ++ intercalate "," (map go ps) go (KeepWeeks n) = mk n 'w' go (KeepMonths n) = mk n 'm' go (KeepYears n) = mk n 'y' - mk n c = show n ++ [c] + mk n c = val n ++ [c] isKeepParam :: ObnamParam -> Bool isKeepParam p = "--keep=" `isPrefixOf` p diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs @@ -28,7 +28,7 @@ providerFor users hn mp = propertyList desc $ props where baseurl = hn ++ case mp of Nothing -> "" - Just p -> ':' : fromPort p + Just p -> ':' : val p url = "http://"++baseurl++"/simpleid" desc = "openid provider " ++ url setbaseurl l diff --git a/src/Propellor/Property/Pacman.hs b/src/Propellor/Property/Pacman.hs @@ -0,0 +1,68 @@ +-- | Maintainer: Zihao Wang <dev@wzhd.org> +-- +-- Support for the Pacman package manager <https://www.archlinux.org/pacman/> + +module Propellor.Property.Pacman where + +import Propellor.Base + +runPacman :: [String] -> UncheckedProperty ArchLinux +runPacman ps = tightenTargets $ cmdProperty "pacman" ps + +-- | Have pacman update its lists of packages, but without upgrading anything. +update :: Property ArchLinux +update = combineProperties ("pacman update") $ props + & runPacman ["-Sy", "--noconfirm"] + `assume` MadeChange + +upgrade :: Property ArchLinux +upgrade = combineProperties ("pacman upgrade") $ props + & runPacman ["-Syu", "--noconfirm"] + `assume` MadeChange + +type Package = String + +installed :: [Package] -> Property ArchLinux +installed = installed' ["--noconfirm"] + +installed' :: [String] -> [Package] -> Property ArchLinux +installed' params ps = check (not <$> isInstalled' ps) go + `describe` unwords ("pacman installed":ps) + where + go = runPacman (params ++ ["-S"] ++ ps) + +removed :: [Package] -> Property ArchLinux +removed ps = check (any (== IsInstalled) <$> getInstallStatus ps) + (runPacman (["-R", "--noconfirm"] ++ ps)) + `describe` unwords ("pacman removed":ps) + +isInstalled :: Package -> IO Bool +isInstalled p = isInstalled' [p] + +isInstalled' :: [Package] -> IO Bool +isInstalled' ps = all (== IsInstalled) <$> getInstallStatus ps + +data InstallStatus = IsInstalled | NotInstalled + deriving (Show, Eq) + +{- Returns the InstallStatus of packages that are installed + - or known and not installed. If a package is not known at all to apt + - or dpkg, it is not included in the list. -} +getInstallStatus :: [Package] -> IO [InstallStatus] +getInstallStatus ps = mapMaybe id <$> mapM status ps + where + status :: Package -> IO (Maybe InstallStatus) + status p = do + ifM (succeeds "pacman" ["-Q", p]) + (return (Just IsInstalled), + ifM (succeeds "pacman" ["-Sp", p]) + (return (Just NotInstalled), + return Nothing)) + +succeeds :: String -> [String] -> IO Bool +succeeds cmd args = (quietProcess >> return True) + `catchIO` (\_ -> return False) + where + quietProcess :: IO () + quietProcess = withQuietOutput createProcessSuccess p + p = (proc cmd args) diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} module Propellor.Property.Parted ( + -- * Types TableType(..), PartTable(..), partTableSize, @@ -15,136 +16,30 @@ module Propellor.Property.Parted ( Partition.MkfsOpts, PartType(..), PartFlag(..), - Eep(..), + -- * Properties partitioned, parted, + Eep(..), installed, + -- * PartSpec combinators + calcPartTable, + DiskSize(..), + DiskPart, + module Propellor.Types.PartSpec, + DiskSpaceUse(..), + useDiskSpace, ) where import Propellor.Base +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 Utility.DataUnits -import Data.Char -import System.Posix.Files - -class PartedVal a where - val :: a -> String - --- | Types of partition tables supported by parted. -data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN - deriving (Show) - -instance PartedVal TableType where - val = map toLower . show - --- | A disk's partition table. -data PartTable = PartTable TableType [Partition] - deriving (Show) - -instance Monoid PartTable where - -- | default TableType is MSDOS - mempty = PartTable MSDOS [] - -- | uses the TableType of the second parameter - mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) - --- | Gets the total size of the disk specified by the partition table. -partTableSize :: PartTable -> ByteSize -partTableSize (PartTable _ ps) = fromPartSize $ - -- add 1 megabyte to hold the partition table itself - mconcat (MegaBytes 1 : map partSize ps) - --- | A partition on the disk. -data Partition = Partition - { partType :: PartType - , partSize :: PartSize - , partFs :: Partition.Fs - , partMkFsOpts :: Partition.MkfsOpts - , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) - , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) - } - deriving (Show) - --- | Makes a Partition with defaults for non-important values. -mkPartition :: Partition.Fs -> PartSize -> Partition -mkPartition fs sz = Partition - { partType = Primary - , partSize = sz - , partFs = fs - , partMkFsOpts = [] - , partFlags = [] - , partName = Nothing - } - --- | Type of a partition. -data PartType = Primary | Logical | Extended - deriving (Show) - -instance PartedVal PartType where - val Primary = "primary" - val Logical = "logical" - val 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 - deriving (Show) - -instance PartedVal PartSize where - val (MegaBytes n) - | n > 0 = show n ++ "MB" - -- parted can't make partitions smaller than 1MB; - -- avoid failure in edge cases - | otherwise = show "1MB" --- | Rounds up to the nearest MegaByte. -toPartSize :: ByteSize -> PartSize -toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double) - -fromPartSize :: PartSize -> ByteSize -fromPartSize (MegaBytes b) = b * 1000000 - -instance Monoid PartSize where - mempty = MegaBytes 0 - mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) - -reducePartSize :: PartSize -> PartSize -> PartSize -reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b) - --- | Flags that can be set on a partition. -data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag - deriving (Show) - -instance PartedVal PartFlag where - val BootFlag = "boot" - val RootFlag = "root" - val SwapFlag = "swap" - val HiddenFlag = "hidden" - val RaidFlag = "raid" - val LvmFlag = "lvm" - val LbaFlag = "lba" - val LegacyBootFlag = "legacy_boot" - val IrstFlag = "irst" - val EspFlag = "esp" - val PaloFlag = "palo" - -instance PartedVal Bool where - val True = "on" - val False = "off" - -instance PartedVal Partition.Fs where - val Partition.EXT2 = "ext2" - val Partition.EXT3 = "ext3" - val Partition.EXT4 = "ext4" - val Partition.BTRFS = "btrfs" - val Partition.REISERFS = "reiserfs" - val Partition.XFS = "xfs" - val Partition.FAT = "fat" - val Partition.VFAT = "vfat" - val Partition.NTFS = "ntfs" - val Partition.LinuxSwap = "linux-swap" +import System.Posix.Files +import Data.List (genericLength) data Eep = YesReallyDeleteDiskContents @@ -167,19 +62,19 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev - mklabel = ["mklabel", val tabletype] + mklabel = ["mklabel", pval tabletype] mkflag partnum (f, b) = [ "set" , show partnum - , val f - , val b + , pval f + , pval b ] mkpart partnum offset p = [ "mkpart" - , val (partType p) - , val (partFs p) - , val offset - , val (offset <> partSize p) + , pval (partType p) + , pval (partFs p) + , pval offset + , pval (offset <> partSize p) ] ++ case partName p of Just n -> ["name", show partnum, n] Nothing -> [] @@ -192,12 +87,76 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do -- -- 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 +parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux) parted YesReallyDeleteDiskContents disk ps = p `requires` installed where p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) `assume` MadeChange -- | Gets parted installed. -installed :: Property DebianLike -installed = Apt.installed ["parted"] +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 +partitionTableOverhead = MegaBytes 1 + +-- | Calculate a partition table, for a given size of disk. +-- +-- For example: +-- +-- > calcPartTable (DiskSize (1024 * 1024 * 1024 * 100)) MSDOS +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setSize` MegaBytes 256 +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `useDisk` RemainingSpace +-- > ] +calcPartTable :: DiskSize -> TableType -> [PartSpec DiskPart] -> PartTable +calcPartTable (DiskSize disksize) tt l = PartTable tt (map go l) + where + go (_, _, mkpart, FixedDiskPart) = mkpart defSz + go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ toPartSize $ + diskremainingafterfixed * fromIntegral p `div` 100 + go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ toPartSize $ + diskremaining `div` genericLength (filter isremainingspace l) + diskremainingafterfixed = + disksize - sumsizes (filter isfixed l) + diskremaining = + disksize - sumsizes (filter (not . isremainingspace) l) + sumsizes = sum . map fromPartSize . (partitionTableOverhead :) . + map (partSize . go) + isfixed (_, _, _, FixedDiskPart) = True + isfixed _ = False + isremainingspace (_, _, _, DynamicDiskPart RemainingSpace) = True + isremainingspace _ = False + +-- | Size of a disk, in bytes. +newtype DiskSize = DiskSize ByteSize + deriving (Show) + +data DiskPart = FixedDiskPart | DynamicDiskPart DiskSpaceUse + +data DiskSpaceUse = Percent Int | RemainingSpace + +instance Monoid DiskPart + where + mempty = FixedDiskPart + mappend FixedDiskPart FixedDiskPart = FixedDiskPart + mappend (DynamicDiskPart (Percent a)) (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent (a + b)) + mappend (DynamicDiskPart RemainingSpace) (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace + mappend (DynamicDiskPart (Percent a)) _ = DynamicDiskPart (Percent a) + mappend _ (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent b) + mappend (DynamicDiskPart RemainingSpace) _ = DynamicDiskPart RemainingSpace + mappend _ (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace + +-- | Make a partition use some percentage of the size of the disk +-- (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) diff --git a/src/Propellor/Property/Parted/Types.hs b/src/Propellor/Property/Parted/Types.hs @@ -0,0 +1,119 @@ +module Propellor.Property.Parted.Types where + +import Propellor.Base +import qualified Propellor.Property.Partition as Partition +import Utility.DataUnits + +import Data.Char + +class PartedVal a where + pval :: a -> String + +-- | Types of partition tables supported by parted. +data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN + deriving (Show) + +instance PartedVal TableType where + pval = map toLower . show + +-- | A disk's partition table. +data PartTable = PartTable TableType [Partition] + deriving (Show) + +instance Monoid PartTable where + -- | default TableType is MSDOS + mempty = PartTable MSDOS [] + -- | uses the TableType of the second parameter + mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) + +-- | A partition on the disk. +data Partition = Partition + { partType :: PartType + , partSize :: PartSize + , partFs :: Partition.Fs + , partMkFsOpts :: Partition.MkfsOpts + , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) + , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) + } + deriving (Show) + +-- | Makes a Partition with defaults for non-important values. +mkPartition :: Partition.Fs -> PartSize -> Partition +mkPartition fs sz = Partition + { partType = Primary + , partSize = sz + , partFs = fs + , partMkFsOpts = [] + , partFlags = [] + , partName = Nothing + } + +-- | Type of a partition. +data PartType = Primary | Logical | Extended + deriving (Show) + +instance PartedVal PartType where + pval Primary = "primary" + 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 + 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) + +fromPartSize :: PartSize -> ByteSize +fromPartSize (MegaBytes b) = b * 1000000 + +instance Monoid PartSize where + mempty = MegaBytes 0 + mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) + +reducePartSize :: PartSize -> PartSize -> PartSize +reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b) + +-- | Flags that can be set on a partition. +data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag + deriving (Show) + +instance PartedVal PartFlag where + pval BootFlag = "boot" + pval RootFlag = "root" + pval SwapFlag = "swap" + pval HiddenFlag = "hidden" + pval RaidFlag = "raid" + pval LvmFlag = "lvm" + pval LbaFlag = "lba" + pval LegacyBootFlag = "legacy_boot" + pval IrstFlag = "irst" + pval EspFlag = "esp" + pval PaloFlag = "palo" + +instance PartedVal Bool where + pval True = "on" + pval False = "off" + +instance PartedVal Partition.Fs where + pval Partition.EXT2 = "ext2" + pval Partition.EXT3 = "ext3" + pval Partition.EXT4 = "ext4" + pval Partition.BTRFS = "btrfs" + pval Partition.REISERFS = "reiserfs" + pval Partition.XFS = "xfs" + pval Partition.FAT = "fat" + pval Partition.VFAT = "vfat" + pval Partition.NTFS = "ntfs" + pval Partition.LinuxSwap = "linux-swap" diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs @@ -9,6 +9,7 @@ import Utility.Applicative import System.Posix.Files import Data.List +import Data.Char -- | Filesystems etc that can be used for a partition. data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap @@ -81,11 +82,26 @@ kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] return r cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] +-- kpartx's output includes the device for the loop partition, and some +-- information about the whole disk loop device. In earlier versions, +-- this was simply the path to the loop device. But, in kpartx 0.6, +-- this changed to the major:minor of the block device. Either is handled +-- by this parser. kpartxParse :: String -> [LoopDev] kpartxParse = mapMaybe (finddev . words) . lines where - finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev - { partitionLoopDev = "/dev/mapper/" ++ ld - , wholeDiskLoopDev = wd - } + finddev ("add":"map":ld:_:_:_:_:s:_) = do + wd <- if isAbsolute s + then Just s + -- A loop partition name loop0pn corresponds to + -- /dev/loop0. It would be more robust to check + -- that the major:minor matches, but haskell's + -- unix library lacks a way to do that. + else case takeWhile isDigit (dropWhile (not . isDigit) ld) of + [] -> Nothing + n -> Just $ "/dev" </> "loop" ++ n + Just $ LoopDev + { partitionLoopDev = "/dev/mapper/" ++ ld + , wholeDiskLoopDev = wd + } finddev _ = Nothing diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs @@ -59,7 +59,7 @@ atEnd force resultok = property "scheduled reboot at end of propellor run" $ do -- See 'Propellor.Property.HostingProvider.DigitalOcean' -- for an example of how to do this. toDistroKernel :: Property DebianLike -toDistroKernel = check (not <$> runningInstalledKernel) now +toDistroKernel = tightenTargets $ check (not <$> runningInstalledKernel) now `describe` "running installed kernel" -- | Given a kernel version string @v@, reboots immediately if the running @@ -78,15 +78,16 @@ toKernelNewerThan ver = property' ("reboot to kernel newer than " ++ ver) $ \w -> do wantV <- tryReadVersion ver runningV <- tryReadVersion =<< liftIO runningKernelVersion - installedV <- maximum <$> - (mapM tryReadVersion =<< liftIO installedKernelVersions) if runningV >= wantV then noChange - else if installedV >= wantV - then ensureProperty w now - else errorMessage $ - "kernel newer than " - ++ ver - ++ " not installed" + else maximum <$> installedVs >>= \installedV -> + if installedV >= wantV + then ensureProperty w now + else errorMessage $ + "kernel newer than " + ++ ver + ++ " not installed" + where + installedVs = mapM tryReadVersion =<< liftIO installedKernelVersions runningInstalledKernel :: IO Bool runningInstalledKernel = do diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs @@ -0,0 +1,202 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the restic backup tool <https://github.com/restic/restic> + +module Propellor.Property.Restic + ( ResticRepo (..) + , installed + , repoExists + , init + , restored + , backup + , backup' + , KeepPolicy (..) + ) where + +import Propellor.Base hiding (init) +import Prelude hiding (init) +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.File as File +import Data.List (intercalate) + +type Url = String + +type ResticParam = String + +data ResticRepo + = Direct FilePath + | SFTP User HostName FilePath + | REST Url + +instance ConfigurableValue ResticRepo where + val (Direct fp) = fp + val (SFTP u h fp) = "sftp:" ++ val u ++ "@" ++ val h ++ ":" ++ fp + val (REST url) = "rest:" ++ url + +installed :: Property DebianLike +installed = withOS desc $ \w o -> case o of + (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $ + Apt.installedBackport ["restic"] + _ -> ensureProperty w $ + Apt.installed ["restic"] + where + desc = "installed restic" + +repoExists :: ResticRepo -> IO Bool +repoExists repo = boolSystem "restic" + [ Param "-r" + , File (val repo) + , Param "--password-file" + , File (getPasswordFile repo) + , Param "snapshots" + ] + +passwordFileDir :: FilePath +passwordFileDir = "/etc/restic-keys" + +getPasswordFile :: ResticRepo -> FilePath +getPasswordFile repo = passwordFileDir </> File.configFileName (val repo) + +passwordFileConfigured :: ResticRepo -> Property (HasInfo + UnixLike) +passwordFileConfigured repo = propertyList "restic password file" $ props + & File.dirExists passwordFileDir + & File.mode passwordFileDir 0O2700 + & getPasswordFile repo `File.hasPrivContent` hostContext + +-- | Inits a new restic repository +init :: ResticRepo -> Property (HasInfo + DebianLike) +init repo = check (not <$> repoExists repo) (cmdProperty "restic" initargs) + `requires` installed + `requires` passwordFileConfigured repo + where + initargs = + [ "-r" + , val repo + , "--password-file" + , getPasswordFile repo + , "init" + ] + +-- | Restores a directory from a restic backup. +-- +-- Only does anything if the directory does not exist, or exists, +-- but is completely empty. +-- +-- The restore is performed atomically; restoring to a temp directory +-- and then moving it to the directory. +restored :: FilePath -> ResticRepo -> Property (HasInfo + DebianLike) +restored dir repo = go + `requires` init repo + where + go :: Property DebianLike + go = property (dir ++ " restored by restic") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do + ok <- boolSystem "restic" + [ Param "-r" + , File (val repo) + , Param "--password-file" + , File (getPasswordFile repo) + , Param "restore" + , Param "latest" + , Param "--target" + , File tmpdir + ] + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running restic with some parameters. +-- +-- If the directory does not exist, or exists but is completely empty, +-- this Property will immediately restore it from an existing backup. +-- +-- So, this property can be used to deploy a directory of content +-- to a host, while also ensuring any changes made to it get backed up. +-- For example: +-- +-- > & Restic.backup "/srv/git" +-- > (Restic.SFTP (User root) (HostName myserver) /mnt/backup/git.restic") +-- > Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Restic.KeepDays 7, Restic.KeepWeeks 4, Restic.KeepMonths 6, Restic.KeepYears 1] +-- +-- Since restic uses a fair amount of system resources, only one restic +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) +backup dir repo crontimes extraargs kp = backup' [dir] repo crontimes extraargs kp + `requires` restored dir repo + +-- | Does a backup, but does not automatically restore. +backup' :: [FilePath] -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) +backup' dirs repo crontimes extraargs kp = cronjob + `describe` desc + `requires` init repo + where + desc = val repo ++ " restic backup" + cronjob = Cron.niceJob ("restic_backup" ++ intercalate "_" dirs) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd + lockfile = "/var/lock/propellor-restic.lock" + backupcmd = intercalate " && " $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "restic" + , "-r" + , shellEscape (val repo) + , "--password-file" + , shellEscape (getPasswordFile repo) + ] + ++ map shellEscape extraargs ++ + [ "backup" ] + ++ map shellEscape dirs + pruneCommand = unwords $ + [ "restic" + , "-r" + , shellEscape (val repo) + , "--password-file" + , shellEscape (getPasswordFile repo) + , "forget" + , "--prune" + ] + ++ + map keepParam kp + +-- | Constructs a ResticParam that specifies which old backup generations to +-- keep. By default, all generations are kept. However, when this parameter is +-- passed to the `backup` property, they will run restic prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> ResticParam +keepParam (KeepLast n) = "--keep-last=" ++ val n +keepParam (KeepHours n) = "--keep-hourly=" ++ val n +keepParam (KeepDays n) = "--keep-daily=" ++ val n +keepParam (KeepWeeks n) = "--keep-weekly=" ++ val n +keepParam (KeepMonths n) = "--keep-monthly=" ++ val n +keepParam (KeepYears n) = "--keep-yearly=" ++ val n + +-- | Policy for backup generations to keep. For example, KeepDays 30 will +-- keep the latest backup for each day when a backup was made, and keep the +-- last 30 such backups. When multiple KeepPolicies are combined together, +-- backups meeting any policy are kept. See restic's man page for details. +data KeepPolicy + = KeepLast Int + | KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs @@ -2,6 +2,7 @@ module Propellor.Property.Rsync where import Propellor.Base import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Pacman as Pacman type Src = FilePath type Dest = FilePath @@ -16,7 +17,7 @@ filesUnder d = Pattern (d ++ "/*") -- | Ensures that the Dest directory exists and has identical contents as -- the Src directory. -syncDir :: Src -> Dest -> Property DebianLike +syncDir :: Src -> Dest -> Property (DebianLike + ArchLinux) syncDir = syncDirFiltered [] data Filter @@ -43,9 +44,9 @@ newtype Pattern = Pattern String -- Rsync checks each name to be transferred against its list of Filter -- rules, and the first matching one is acted on. If no matching rule -- is found, the file is processed. -syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike +syncDirFiltered :: [Filter] -> Src -> Dest -> Property (DebianLike + ArchLinux) syncDirFiltered filters src dest = rsync $ - [ "-av" + [ "-a" -- Add trailing '/' to get rsync to sync the Dest directory, -- rather than a subdir inside it, which it will do without a -- trailing '/'. @@ -53,10 +54,13 @@ syncDirFiltered filters src dest = rsync $ , addTrailingPathSeparator dest , "--delete" , "--delete-excluded" - , "--quiet" + , "--info=progress2" ] ++ map toRsync filters -rsync :: [String] -> Property DebianLike +rsync :: [String] -> Property (DebianLike + ArchLinux) rsync ps = cmdProperty "rsync" ps `assume` MadeChange - `requires` Apt.installed ["rsync"] + `requires` installed + +installed :: Property (DebianLike + ArchLinux) +installed = Apt.installed ["rsync"] `pickOS` Pacman.installed ["rsync"] diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs @@ -20,12 +20,10 @@ Debian stretch, which older sbuild can't handle. Suggested usage in @config.hs@: -> & Apt.installed ["piuparts", "autopkgtest"] +> & Apt.installed ["piuparts", "autopkgtest", "lintian"] > & Sbuild.builtFor (System (Debian Linux Unstable) X86_32) Sbuild.UseCcache -> & Sbuild.piupartsConfFor (System (Debian Linux Unstable) X86_32) > & Sbuild.updatedFor (System (Debian Linux Unstable) X86_32) `period` Weekly 1 > & Sbuild.usableBy (User "spwhitton") -> & Sbuild.shareAptCache > & Schroot.overlaysInTmpfs If you are using sbuild older than 0.70.0, you also need: @@ -34,15 +32,13 @@ If you are using sbuild older than 0.70.0, you also need: In @~/.sbuildrc@ (sbuild 0.71.0 or newer): -> $run_piuparts = 1; > $piuparts_opts = [ +> '--no-eatmydata', > '--schroot', -> '%r-%a-piuparts', +> '%r-%a-sbuild', > '--fail-if-inadequate', -> '--fail-on-broken-symlinks', > ]; > -> $run_autopkgtest = 1; > $autopkgtest_root_args = ""; > $autopkgtest_opts = ["--", "schroot", "%r-%a-sbuild"]; @@ -53,9 +49,9 @@ 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 an apt -cacher. In that case you can do something like this in @config.hs@: +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 @@ -74,20 +70,19 @@ module Propellor.Property.Sbuild ( UseCcache(..), built, updated, - piupartsConf, builtFor, updatedFor, - piupartsConfFor, -- * Global sbuild configuration -- blockNetwork, installed, keypairGenerated, keypairInsecurelyGenerated, - shareAptCache, usableBy, + userConfig, ) where import Propellor.Base +import Propellor.Types.Info import Propellor.Property.Debootstrap (extractSuite) import Propellor.Property.Chroot.Util import qualified Propellor.Property.Apt as Apt @@ -98,10 +93,10 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Schroot as Schroot import qualified Propellor.Property.Reboot as Reboot import qualified Propellor.Property.User as User - import Utility.FileMode +import Utility.Split + import Data.List -import Data.List.Utils type Suite = String @@ -111,8 +106,8 @@ type Suite = String -- the same suite and the same architecture, so neither do we data SbuildSchroot = SbuildSchroot Suite Architecture -instance Show SbuildSchroot where - show (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch +instance ConfigurableValue SbuildSchroot where + val (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch -- | Whether an sbuild schroot should use ccache during builds -- @@ -128,9 +123,9 @@ data UseCcache = UseCcache | NoCcache builtFor :: System -> UseCcache -> RevertableProperty DebianLike UnixLike builtFor sys cc = go <!> deleted where - go = property' ("sbuild schroot for " ++ show sys) $ - \w -> case (schrootFromSystem sys, stdMirror sys) of - (Just s, Just u) -> ensureProperty w $ + 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) @@ -139,6 +134,7 @@ builtFor sys cc = go <!> deleted 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 @@ -146,12 +142,13 @@ built s@(SbuildSchroot suite arch) mirror cc = ((go `before` enhancedConf) `requires` ccacheMaybePrepared cc `requires` installed - `requires` overlaysKernel) + `requires` overlaysKernel + `requires` cleanupOldConfig) <!> deleted where go :: Property DebianLike go = check (unpopulated (schrootRoot s) <||> ispartial) $ - property' ("built sbuild schroot for " ++ show s) make + property' ("built sbuild schroot for " ++ val s) make make w = do de <- liftIO standardPathEnv let params = Param <$> @@ -170,22 +167,49 @@ built s@(SbuildSchroot suite arch) mirror cc = -- TODO we should kill any sessions still using the chroot -- before destroying it (as suggested by sbuild-destroychroot) deleted = check (not <$> unpopulated (schrootRoot s)) $ - property ("no sbuild schroot for " ++ show s) $ do + property ("no sbuild schroot for " ++ val s) $ do liftIO $ removeChroot $ schrootRoot s liftIO $ nukeFile - ("/etc/sbuild/chroot" </> show s ++ "-sbuild") + ("/etc/sbuild/chroot" </> val s ++ "-sbuild") makeChange $ nukeFile (schrootConf s) enhancedConf = - combineProperties ("enhanced schroot conf for " ++ show s) $ props + 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) - ( show s ++ "-sbuild" + ( 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") + 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 ++ "\";" ] + -- 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. @@ -196,7 +220,7 @@ built s@(SbuildSchroot suite arch) mirror cc = then ensureProperty w $ ConfFile.containsIniSetting (schrootConf s) - ( show s ++ "-sbuild" + ( val s ++ "-sbuild" , "aliases" , aliases ) @@ -217,6 +241,21 @@ built s@(SbuildSchroot suite arch) mirror cc = Reboot.toKernelNewerThan "3.18" else noChange + -- clean up config from earlier versions of this module + cleanupOldConfig :: Property UnixLike + cleanupOldConfig = + property' "old sbuild module config cleaned up" $ \w -> do + void $ ensureProperty w $ + check (doesFileExist fstab) + (File.lacksLine fstab aptCacheLine) + void $ liftIO . tryIO $ removeDirectoryRecursive profile + void $ liftIO $ nukeFile (schrootPiupartsConf s) + -- 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")) @@ -263,7 +302,7 @@ updatedFor system = property' ("updated sbuild schroot for " ++ show system) $ updated :: SbuildSchroot -> Property DebianLike updated s@(SbuildSchroot suite arch) = check (doesDirectoryExist (schrootRoot s)) $ go - `describe` ("updated schroot for " ++ show s) + `describe` ("updated schroot for " ++ val s) `requires` installed where go :: Property DebianLike @@ -283,13 +322,13 @@ updated s@(SbuildSchroot suite arch) = -- 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 " ++ show s ++ " config file fixed") $ \w -> do + 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" </> show s ++ "-propellor") - ("/etc/sbuild/chroot" </> show s ++ "-sbuild") + ("/etc/sbuild/chroot" </> val s ++ "-propellor") + ("/etc/sbuild/chroot" </> val s ++ "-sbuild") ensureProperty w $ File.fileProperty "replace dummy suffix" (map munge) new where @@ -298,92 +337,6 @@ fixConfFile s@(SbuildSchroot suite arch) = tempPrefix = dir </> suite ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-" munge = replace "-propellor]" "-sbuild]" --- | Create a corresponding schroot config file for use with piuparts --- --- This function is a convenience wrapper around 'piupartsConf', allowing the --- user to identify the schroot using the 'System' type. See that function's --- documentation for why you might want to use this property, and sample config. -piupartsConfFor :: System -> Property DebianLike -piupartsConfFor sys = property' ("piuparts schroot conf for " ++ show sys) $ - \w -> case schrootFromSystem sys of - Just s -> ensureProperty w $ piupartsConf s - _ -> errorMessage - ("don't know how to debootstrap " ++ show sys) - --- | Create a corresponding schroot config file for use with piuparts --- --- This is useful because: --- --- - piuparts will clear out the apt cache which makes 'shareAptCache' much less --- useful --- --- - piuparts itself invokes eatmydata, so the command-prefix setting in our --- regular schroot config would force the user to pass @--no-eatmydata@ to --- piuparts in their @~/.sbuildrc@, which is inconvenient. --- --- To make use of this new schroot config, you can put something like this in --- your ~/.sbuildrc (sbuild 0.71.0 or newer): --- --- > $run_piuparts = 1; --- > $piuparts_opts = [ --- > '--schroot', --- > '%r-%a-piuparts', --- > '--fail-if-inadequate', --- > '--fail-on-broken-symlinks', --- > ]; --- --- This property has no effect if the corresponding sbuild schroot does not --- exist (i.e. you also need 'Sbuild.built' or 'Sbuild.builtFor'). -piupartsConf :: SbuildSchroot -> Property DebianLike -piupartsConf s@(SbuildSchroot _ arch) = - check (doesFileExist (schrootConf s)) go - `requires` installed - where - go :: Property DebianLike - go = property' desc $ \w -> do - aliases <- aliasesLine - ensureProperty w $ combineProperties desc $ props - & check (not <$> doesFileExist f) - (File.basedOn f (schrootConf s, map munge)) - & ConfFile.containsIniSetting f - (sec, "profile", "piuparts") - & ConfFile.containsIniSetting f - (sec, "aliases", aliases) - & ConfFile.containsIniSetting f - (sec, "command-prefix", "") - & File.dirExists dir - & File.isSymlinkedTo (dir </> "copyfiles") - (File.LinkTarget $ orig </> "copyfiles") - & File.isSymlinkedTo (dir </> "nssdatabases") - (File.LinkTarget $ orig </> "nssdatabases") - & File.basedOn (dir </> "fstab") - (orig </> "fstab", filter (/= aptCacheLine)) - - orig = "/etc/schroot/sbuild" - dir = "/etc/schroot/piuparts" - sec = show s ++ "-piuparts" - f = schrootPiupartsConf s - munge = replace "-sbuild]" "-piuparts]" - desc = "piuparts schroot conf for " ++ show s - - -- normally the piuparts schroot conf has no aliases, but we have to add - -- one, for dgit compatibility, if this is the default sid chroot - aliasesLine = sidHostArchSchroot s >>= \isSidHostArchSchroot -> - return $ if isSidHostArchSchroot - then "UNRELEASED-" - ++ architectureToDebianArchString arch - ++ "-piuparts" - else "" - --- | Bind-mount /var/cache/apt/archives in all sbuild chroots so that the host --- system and the chroot share the apt cache --- --- This speeds up builds by avoiding unnecessary downloads of build --- dependencies. -shareAptCache :: Property DebianLike -shareAptCache = File.containsLine "/etc/schroot/sbuild/fstab" aptCacheLine - `requires` installed - `describe` "sbuild schroots share host apt cache" aptCacheLine :: String aptCacheLine = "/var/cache/apt/archives /var/cache/apt/archives none rw,bind 0 0" @@ -493,6 +446,35 @@ ccachePrepared = propertyList "sbuild group ccache configured" $ props -- [Firewall.IPWithNumMask (IPv4 "127.0.0.1") 8]) -- `requires` installed -- sbuild group must exist +-- | Maintain recommended ~/.sbuildrc for a user, and adds them to the +-- sbuild group +-- +-- You probably want a custom ~/.sbuildrc on your workstation, but +-- this property is handy for quickly setting up build boxes. +userConfig :: User -> Property DebianLike +userConfig user@(User u) = go + `requires` usableBy user + `requires` Apt.installed ["piuparts", "autopkgtest", "lintian"] + where + go :: Property DebianLike + go = property' ("~/.sbuildrc for " ++ u) $ \w -> do + h <- liftIO (User.homedir user) + ensureProperty w $ File.hasContent (h </> ".sbuildrc") + [ "$run_lintian = 1;" + , "" + , "$run_piuparts = 1;" + , "$piuparts_opts = [" + , " '--no-eatmydata'," + , " '--schroot'," + , " '%r-%a-sbuild'," + , " '--fail-if-inadequate'," + , " ];" + , "" + , "$run_autopkgtest = 1;" + , "$autopkgtest_root_args = \"\";" + , "$autopkgtest_opts = [\"--\", \"schroot\", \"%r-%a-sbuild\"];" + ] + -- ==== utility functions ==== schrootFromSystem :: System -> Maybe SbuildSchroot @@ -500,11 +482,6 @@ schrootFromSystem system@(System _ arch) = extractSuite system >>= \suite -> return $ SbuildSchroot suite arch -stdMirror :: System -> Maybe Apt.Url -stdMirror (System (Debian _ _) _) = Just "http://httpredir.debian.org/debian" -stdMirror (System (Buntish _) _) = Just "mirror://mirrors.ubuntu.com/" -stdMirror _ = Nothing - schrootRoot :: SbuildSchroot -> FilePath schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ architectureToDebianArchString a @@ -527,7 +504,7 @@ schrootPiupartsConf (SbuildSchroot s a) = sidHostArchSchroot :: SbuildSchroot -> Propellor Bool sidHostArchSchroot (SbuildSchroot suite arch) = do maybeOS <- getOS - case maybeOS of - Nothing -> return False + return $ case maybeOS of + Nothing -> False Just (System _ hostArch) -> - return $ suite == "unstable" && hostArch == arch + suite == "unstable" && hostArch == arch diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -143,15 +143,15 @@ stackAutoBuilder suite arch flavor = stackInstalled :: Property Linux stackInstalled = withOS "stack installed" $ \w o -> case o of - (Just (System (Debian Linux (Stable "jessie")) X86_32)) -> - ensureProperty w $ manualinstall X86_32 + (Just (System (Debian Linux (Stable "jessie")) arch)) -> + ensureProperty w $ manualinstall arch _ -> ensureProperty w $ Apt.installed ["haskell-stack"] where -- Warning: Using a binary downloaded w/o validation. manualinstall :: Architecture -> Property Linux manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $ propertyList "stack installed from upstream tarball" $ props - & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ architectureToDebianArchString arch, "-O", tmptar] + & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ archname, "-O", tmptar] `assume` MadeChange & File.dirExists tmpdir & cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"] @@ -160,6 +160,15 @@ stackInstalled = withOS "stack installed" $ \w o -> `assume` MadeChange & cmdProperty "rm" ["-rf", tmpdir, tmptar] `assume` MadeChange + where + -- See https://www.stackage.org/stack/ for the list of + -- binaries. + archname = case arch of + X86_32 -> "i386" + X86_64 -> "x86_64" + ARMHF -> "arm" + -- Probably not available. + a -> architectureToDebianArchString a binstack = "/usr/bin/stack" tmptar = "/root/stack.tar.gz" tmpdir = "/root/stack" diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -19,13 +19,14 @@ import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Systemd as Systemd +import qualified Propellor.Property.Network as Network import qualified Propellor.Property.Fail2Ban as Fail2Ban import qualified Propellor.Property.LetsEncrypt as LetsEncrypt import Utility.FileMode +import Utility.Split import Data.List import System.Posix.Files -import Data.String.Utils scrollBox :: Property (HasInfo + DebianLike) scrollBox = propertyList "scroll server" $ props @@ -78,7 +79,8 @@ scrollBox = propertyList "scroll server" $ props `onChange` Ssh.restarted & User.shellSetTo (User "scroll") s & User.hasPassword (User "scroll") - & Apt.serviceInstalledRunning "telnetd" + -- telnetd attracted password crackers, so disabled + & Apt.removed ["telnetd"] & Apt.installed ["shellinabox"] & File.hasContent "/etc/default/shellinabox" [ "# Deployed by propellor" @@ -227,23 +229,29 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") `requires` Ssh.authorizedKeys (User "family") (Context "git.kitenet.net") `requires` User.accountFor (User "family") - & Apt.installed ["git", "rsync", "gitweb"] + & Apt.installed ["git", "rsync", "cgit"] & Apt.installed ["git-annex"] & Apt.installed ["kgb-client"] & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext `requires` File.dirExists "/etc/kgb-bot/" & Git.daemonRunning "/srv/git" - & "/etc/gitweb.conf" `File.containsLines` - [ "$projectroot = '/srv/git';" - , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" - , "# disable snapshot download; overloads server" - , "$feature{'snapshot'}{'default'} = [];" - ] - `describe` "gitweb configured" - -- Repos push on to github. - & Ssh.knownHost hosts "github.com" (User "joey") - -- I keep the website used for gitweb checked into git.. - & Git.cloned (User "root") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + & "/etc/cgitrc" `File.hasContent` + [ "clone-url=https://git.joeyh.name/git/$CGIT_REPO_URL git://git.joeyh.name/$CGIT_REPO_URL" + , "css=/cgit-css/cgit.css" + , "logo=/cgit-css/cgit.png" + , "enable-http-clone=1" + , "root-title=Joey's git repositories" + , "root-desc=" + , "enable-index-owner=0" + , "snapshots=tar.gz" + , "enable-git-config=1" + , "scan-path=/srv/git" + ] + `describe` "cgit configured" + -- I keep the website used for git.kitenet.net/git.joeyh.name checked into git.. + & Git.cloned (User "joey") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + -- Don't need global apache configuration for cgit. + ! Apache.confEnabled "cgit" & website "git.kitenet.net" & website "git.joeyh.name" & Apache.modEnabled "cgi" @@ -313,9 +321,9 @@ apacheSite hn middle = Apache.siteEnabled hn $ apachecfg hn middle apachecfg :: HostName -> Apache.ConfigFile -> Apache.ConfigFile apachecfg hn middle = - [ "<VirtualHost *:"++show port++">" + [ "<VirtualHost *:" ++ val port ++ ">" , " ServerAdmin grue@joeyh.name" - , " ServerName "++hn++":"++show port + , " ServerName "++hn++":" ++ val port ] ++ middle ++ [ "" @@ -328,7 +336,7 @@ apachecfg hn middle = , "</VirtualHost>" ] where - port = 80 :: Int + port = Port 80 gitAnnexDistributor :: Property (HasInfo + DebianLike) gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props @@ -369,7 +377,7 @@ tmp = propertyList "tmp.joeyh.name" $ props -- (Obsolete; need to revert this.) pumpRss :: Property DebianLike pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.joeyh.name/" - "wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom" + "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom" ircBouncer :: Property (HasInfo + DebianLike) ircBouncer = propertyList "IRC bouncer" $ props @@ -404,8 +412,6 @@ githubBackup = propertyList "github-backup box" $ props & githubKeys & Cron.niceJob "github-backup run" (Cron.Times "30 4 * * *") (User "joey") "/home/joey/lib/backup" backupcmd - & Cron.niceJob "gitriddance" (Cron.Times "30 4 * * *") (User "joey") - "/home/joey/lib/backup" gitriddancecmd where backupcmd = intercalate "&&" $ [ "mkdir -p github" @@ -413,11 +419,6 @@ githubBackup = propertyList "github-backup box" $ props , ". $HOME/.github-keys" , "github-backup joeyh" ] - gitriddancecmd = intercalate "&&" $ - [ "cd github" - , ". $HOME/.github-keys" - ] ++ map gitriddance githubMirrors - gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" githubKeys :: Property (HasInfo + UnixLike) githubKeys = @@ -426,19 +427,6 @@ githubKeys = `onChange` File.ownerGroup f (User "joey") (Group "joey") --- these repos are only mirrored on github, I don't want --- all the proprietary features -githubMirrors :: [(String, String)] -githubMirrors = - [ ("ikiwiki", plzuseurl "http://ikiwiki.info/todo/") - , ("git-annex", plzuseurl "http://git-annex.branchable.com/todo/") - , ("myrepos", plzuseurl "http://myrepos.branchable.com/todo/") - , ("propellor", plzuseurl "http://propellor.branchable.com/todo/") - , ("etckeeper", plzuseurl "http://etckeeper.branchable.com/todo/") - ] - where - plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess" - rsyncNetBackup :: [Host] -> Property DebianLike rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *") (User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" @@ -532,7 +520,6 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props & "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases - & hasPostfixCert ctx & "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" @@ -586,8 +573,8 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "# Enable postgrey." , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_sasl_authenticated,,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" - , "# Enable spamass-milter, amavis-milter, opendkim" - , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" + , "# Enable spamass-milter, amavis-milter (opendkim is not enabled because it causes mails forwarded from eg gmail to be rejected)" + , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock" , "# opendkim is used for outgoing mail" , "non_smtpd_milters = inet:localhost:8891" , "milter_connect_macros = j {daemon_name} v {if_name} _" @@ -595,9 +582,9 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "milter_default_action = accept" , "# TLS setup -- server" - , "smtpd_tls_CAfile = /etc/ssl/certs/joeyca.pem" - , "smtpd_tls_cert_file = /etc/ssl/certs/postfix.pem" - , "smtpd_tls_key_file = /etc/ssl/private/postfix.pem" + , "smtpd_tls_CAfile = /etc/letsencrypt/live/kitenet.net/fullchain.pem" + , "smtpd_tls_cert_file = /etc/letsencrypt/live/kitenet.net/cert.pem" + , "smtpd_tls_key_file = /etc/letsencrypt/live/kitenet.net/privkey.pem" , "smtpd_tls_loglevel = 1" , "smtpd_tls_received_header = yes" , "smtpd_use_tls = yes" @@ -605,9 +592,9 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "smtpd_tls_session_cache_database = sdbm:/etc/postfix/smtpd_scache" , "# TLS setup -- client" - , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" - , "smtp_tls_cert_file = /etc/ssl/certs/postfix.pem" - , "smtp_tls_key_file = /etc/ssl/private/postfix.pem" + , "smtp_tls_CAfile = /etc/letsencrypt/live/kitenet.net/fullchain.pem" + , "smtp_tls_cert_file = /etc/letsencrypt/live/kitenet.net/cert.pem" + , "smtp_tls_key_file = /etc/letsencrypt/live/kitenet.net/privkey.pem" , "smtp_tls_loglevel = 1" , "smtp_use_tls = yes" , "smtp_tls_session_cache_database = sdbm:/etc/postfix/smtp_scache" @@ -626,6 +613,12 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props "!include auth-passwdfile.conf.ext" `onChange` Service.restarted "dovecot" `describe` "dovecot auth.conf" + & "/etc/dovecot/conf.d/10-ssl.conf" `File.containsLines` + [ "ssl_cert = </etc/letsencrypt/live/kitenet.net/fullchain.pem" + , "ssl_key = </etc/letsencrypt/live/kitenet.net/privkey.pem" + ] + `onChange` Service.restarted "dovecot" + `describe` "dovecot letsencrypt certs" & File.hasPrivContent dovecotusers ctx `onChange` (dovecotusers `File.mode` combineModes [ownerReadMode, groupReadMode]) @@ -694,6 +687,10 @@ dkimInstalled = go `onChange` Service.restarted "opendkim" & File.ownerGroup "/etc/mail/dkim.key" (User "opendkim") (Group "opendkim") & "/etc/default/opendkim" `File.containsLine` "SOCKET=\"inet:8891@localhost\"" + `onChange` + (cmdProperty "/lib/opendkim/opendkim.service.generate" [] + `assume` MadeChange) + `onChange` Service.restarted "opendkim" & "/etc/opendkim.conf" `File.containsLines` [ "KeyFile /etc/mail/dkim.key" , "SubDomains yes" @@ -707,14 +704,20 @@ dkimInstalled = go `onChange` Service.restarted "opendkim" domainKey :: (BindDomain, Record) domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") -hasJoeyCAChain :: Property (HasInfo + UnixLike) -hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` - Context "joeyca.pem" - -hasPostfixCert :: Context -> Property (HasInfo + UnixLike) -hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props - & "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx - & "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx +postfixSaslPasswordClient :: Property (HasInfo + DebianLike) +postfixSaslPasswordClient = combineProperties "postfix uses SASL password to authenticate with smarthost" $ props + & Postfix.satellite + & Postfix.mappedFile "/etc/postfix/sasl_passwd" + (`File.hasPrivContent` (Context "kitenet.net")) + & Postfix.mainCfFile `File.containsLines` + [ "# TLS setup for SASL auth to kite" + , "smtp_sasl_auth_enable = yes" + , "smtp_tls_security_level = encrypt" + , "smtp_sasl_tls_security_options = noanonymous" + , "relayhost = [kitenet.net]" + , "smtp_sasl_password_maps = hash:/etc/postfix/sasl_passwd" + ] + `onChange` Postfix.reloaded -- Legacy static web sites and redirections from kitenet.net to newer -- sites. @@ -790,6 +793,15 @@ legacyWebSites = propertyList "legacy web sites" $ props , "# Redirect all to joeyh.name." , "rewriterule (.*) http://joeyh.name$1 [r]" ] + & alias "homepower.joeyh.name" + & apacheSite "homepower.joeyh.name" + [ "DocumentRoot /srv/web/homepower.joeyh.name" + , "<Directory /srv/web/homepower.joeyh.name>" + , " Options Indexes ExecCGI" + , " AllowOverride None" + , Apache.allowAll + , "</Directory>" + ] where kitenetcfg = -- /var/www is empty @@ -891,7 +903,7 @@ userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf -- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/> -- -- oncalendar example value: "*-*-* 7:30" -alarmClock :: String -> User -> String -> Property DebianLike +alarmClock :: String -> User -> String -> Property Linux alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props & "/etc/systemd/system/goodmorning.timer" `File.hasContent` [ "[Unit]" @@ -925,3 +937,124 @@ alarmClock oncalendar (User user) command = combineProperties "goodmorning timer & Systemd.started "goodmorning.timer" & "/etc/systemd/logind.conf" `ConfFile.containsIniSetting` ("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 + & Apache.installed + & Apt.installed ["python2", "python-pymodbus"] + & File.ownerGroup "/var/www/html" user (userGroup user) + & Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing + `onChange` buildpoller + & Systemd.enabled servicename + `requires` serviceinstalled + `onChange` Systemd.started servicename + & Cron.niceJob "homepower upload" + (Cron.Times "1 * * * *") user d rsynccommand + `requires` Ssh.userKeyAt (Just sshkeyfile) user ctx sshkey + where + d = "/var/www/html/homepower" + sshkeyfile = d </> ".ssh/key" + buildpoller = userScriptProperty (User "joey") + [ "cd " ++ d + , "make" + ] + `assume` MadeChange + `requires` Apt.installed ["ghc", "make"] + servicename = "homepower" + servicefile = "/etc/systemd/system/" ++ servicename ++ ".service" + serviceinstalled = servicefile `File.hasContent` + [ "[Unit]" + , "Description=home power monitor" + , "" + , "[Service]" + , "ExecStart=" ++ d ++ "/poller" + , "WorkingDirectory=" ++ d + , "User=joey" + , "Group=joey" + , "" + , "[Install]" + , "WantedBy=multi-user.target" + ] + -- Only upload when eth0 is up; eg the satellite internet is up. + -- Any changes to the rsync command will need my .authorized_keys + -- rsync server command to be updated too. + rsynccommand = "if ip route | grep '^default' | grep -q eth0; then rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/recent/ joey@kitenet.net:/srv/web/homepower.joeyh.name/rrds/recent/; fi" + +-- My home router, running hostapd and dnsmasq for wlan0, +-- with eth0 connected to a satellite modem, and a fallback ppp connection. +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" + [ "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" + ] + & ipmasq "wlan0" + & Apt.serviceInstalledRunning "netplug" + & Network.dhcp' "eth0" + -- When satellite is down, fall back to dialup + [ ("pre-up", "poff -a || true") + , ("post-down", "pon") + ] + `requires` Network.cleanInterfacesFile + & Apt.installed ["ppp"] + `before` File.hasContent "/etc/ppp/peers/provider" + [ "user \"joeyh@arczip.com\"" + , "connect \"/usr/sbin/chat -v -f /etc/chatscripts/pap -T 9734111\"" + , "/dev/ttyACM0" + , "115200" + , "noipdefault" + , "defaultroute" + , "persist" + , "noauth" + ] + `before` File.hasPrivContent "/etc/ppp/pap-secrets" (Context "joeyh@arczip.com") + +-- | Enable IP masqerading, on whatever other interfaces come up than the +-- provided intif. +ipmasq :: String -> Property DebianLike +ipmasq intif = File.hasContent ifupscript + [ "#!/bin/sh" + , "INTIF=" ++ intif + , "if [ \"$IFACE\" = $INTIF ] || [ \"$IFACE\" = lo ]; then" + , "exit 0" + , "fi" + , "iptables -F" + , "iptables -A FORWARD -i $IFACE -o $INTIF -m state --state ESTABLISHED,RELATED -j ACCEPT" + , "iptables -A FORWARD -i $INTIF -o $IFACE -j ACCEPT" + , "iptables -t nat -A POSTROUTING -o $IFACE -j MASQUERADE" + , "echo 1 > /proc/sys/net/ipv4/ip_forward" + ] + `before` scriptmode ifupscript + `before` File.hasContent pppupscript + [ "#!/bin/sh" + , "IFACE=$PPP_IFACE " ++ ifupscript + ] + `before` scriptmode pppupscript + `requires` Apt.installed ["iptables"] + where + ifupscript = "/etc/network/if-up.d/ipmasq" + pppupscript = "/etc/ppp/ip-up.d/ipmasq" + scriptmode f = f `File.mode` combineModes (readModes ++ executeModes) diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs @@ -69,11 +69,11 @@ setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed) setSshdConfig :: ConfigKeyword -> String -> Property DebianLike -setSshdConfig setting val = File.fileProperty desc f sshdConfig +setSshdConfig setting v = File.fileProperty desc f sshdConfig `onChange` restarted where - desc = unwords [ "ssh config:", setting, val ] - cfgline = setting ++ " " ++ val + desc = unwords [ "ssh config:", setting, v ] + cfgline = setting ++ " " ++ v wantedline s | s == cfgline = True | (setting ++ " ") `isPrefixOf` s = False @@ -120,7 +120,7 @@ dotFile f user = do listenPort :: Port -> RevertableProperty DebianLike DebianLike listenPort port = enable <!> disable where - portline = "Port " ++ fromPort port + portline = "Port " ++ val port enable = sshdConfig `File.containsLine` portline `describe` ("ssh listening on " ++ portline) `onChange` restarted @@ -227,7 +227,7 @@ newtype HostKeyInfo = HostKeyInfo deriving (Eq, Ord, Typeable, Show) instance IsInfo HostKeyInfo where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False instance Monoid HostKeyInfo where mempty = HostKeyInfo M.empty @@ -248,7 +248,7 @@ newtype UserKeyInfo = UserKeyInfo deriving (Eq, Ord, Typeable, Show) instance IsInfo UserKeyInfo where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False instance Monoid UserKeyInfo where mempty = UserKeyInfo M.empty diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs @@ -9,23 +9,33 @@ import Propellor.Property.User -- | Allows a user to sudo. If the user has a password, sudo is configured -- to require it. If not, NOPASSWORD is enabled for the user. -enabledFor :: User -> Property DebianLike -enabledFor user@(User u) = go `requires` Apt.installed ["sudo"] +enabledFor :: User -> RevertableProperty DebianLike DebianLike +enabledFor user@(User u) = setup `requires` Apt.installed ["sudo"] <!> cleanup where - go :: Property UnixLike - go = property' desc $ \w -> do + setup :: Property UnixLike + setup = property' desc $ \w -> do locked <- liftIO $ isLockedPassword user ensureProperty w $ fileProperty desc (modify locked . filter (wanted locked)) - "/etc/sudoers" - desc = u ++ " is sudoer" + sudoers + where + desc = u ++ " is sudoer" + + cleanup :: Property DebianLike + cleanup = tightenTargets $ + fileProperty desc (filter notuserline) sudoers + where + desc = u ++ " is not sudoer" + + sudoers = "/etc/sudoers" sudobaseline = u ++ " ALL=(ALL:ALL)" + notuserline l = not (sudobaseline `isPrefixOf` l) sudoline True = sudobaseline ++ " NOPASSWD:ALL" sudoline False = sudobaseline ++ " ALL" wanted locked l -- TOOD: Full sudoers file format parse.. - | not (sudobaseline `isPrefixOf` l) = True + | notuserline l = True | "NOPASSWD" `isInfixOf` l = locked | otherwise = True modify locked ls diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs @@ -55,9 +55,9 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import Propellor.Property.Systemd.Core import Utility.FileMode +import Utility.Split import Data.List -import Data.List.Utils import qualified Data.Map as M type ServiceName = String @@ -259,7 +259,7 @@ debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux -nspawned c@(Container name (Chroot.Chroot loc builder _) h) = +nspawned c@(Container name (Chroot.Chroot loc builder _ _) h) = p `describe` ("nspawned " ++ name) where p :: RevertableProperty (HasInfo + Linux) Linux @@ -271,7 +271,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- Chroot provisioning is run in systemd-only mode, -- which sets up the chroot and ensures systemd and dbus are -- installed, but does not handle the other properties. - chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True + chrootprovisioned = Chroot.provisioned' chroot True -- Use nsenter to enter container and and run propellor to -- finish provisioning. @@ -281,56 +281,44 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = <!> doNothing - chroot = Chroot.Chroot loc builder h + chroot = Chroot.Chroot loc builder Chroot.propagateChrootInfo h --- | Sets up the service file for the container, and then starts --- it running. +-- | Sets up the service files for the container, using the +-- systemd-nspawn@.service template, and starts it running. nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux nspawnService (Container name _ _) cfg = setup <!> teardown where service = nspawnServiceName name - servicefile = "/etc/systemd/system/multi-user.target.wants" </> service - - servicefilecontent = do - ls <- lines <$> readFile "/lib/systemd/system/systemd-nspawn@.service" - return $ unlines $ - "# deployed by propellor" : map addparams ls - addparams l - | "ExecStart=" `isPrefixOf` l = unwords $ - [ "ExecStart = /usr/bin/systemd-nspawn" - , "--quiet" - , "--keep-unit" - , "--boot" - , "--directory=" ++ containerDir name - , "--machine=%i" - ] ++ nspawnServiceParams cfg - | otherwise = l - - goodservicefile = (==) - <$> servicefilecontent - <*> catchDefaultIO "" (readFile servicefile) - - writeservicefile :: Property Linux - writeservicefile = property servicefile $ makeChange $ do - c <- servicefilecontent - File.viaStableTmp (\t -> writeFile t c) servicefile - - setupservicefile :: Property Linux - setupservicefile = check (not <$> goodservicefile) $ - -- if it's running, it has the wrong configuration, - -- so stop it - stopped service - `requires` daemonReloaded - `requires` writeservicefile + overridedir = "/etc/systemd/system" </> nspawnServiceName name ++ ".d" + overridefile = overridedir </> "local.conf" + overridecontent = + [ "[Service]" + , "# Reset ExecStart from the template" + , "ExecStart=" + , "ExecStart=/usr/bin/systemd-nspawn " ++ unwords nspawnparams + ] + nspawnparams = + [ "--quiet" + , "--keep-unit" + , "--boot" + , "--directory=" ++ containerDir name + , "--machine=" ++ name + ] ++ nspawnServiceParams cfg + + overrideconfigured = File.hasContent overridefile overridecontent + `onChange` daemonReloaded + `requires` File.dirExists overridedir setup :: Property Linux setup = started service - `requires` setupservicefile + `requires` enabled service + `requires` overrideconfigured `requires` machined teardown :: Property Linux - teardown = check (doesFileExist servicefile) $ - disabled service `requires` stopped service + teardown = stopped service + `before` disabled service + `before` File.notPresent overridefile nspawnServiceParams :: ChrootCfg -> [String] nspawnServiceParams NoChrootCfg = [] @@ -421,7 +409,7 @@ class Publishable a where toPublish :: a -> String instance Publishable Port where - toPublish port = fromPort port + toPublish port = val port instance Publishable (Bound Port) where toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v) diff --git a/src/Propellor/Property/Timezone.hs b/src/Propellor/Property/Timezone.hs @@ -0,0 +1,21 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.Timezone where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File + +-- | A timezone from /usr/share/zoneinfo +type Timezone = String + +-- | Sets the system's timezone +configured :: Timezone -> Property DebianLike +configured zone = File.hasContent "/etc/timezone" [zone] + `onChange` update + `describe` (zone ++ " timezone configured") + where + update = Apt.reConfigure "tzdata" mempty + -- work around a bug in recent tzdata. See + -- https://bugs.launchpad.net/ubuntu/+source/tzdata/+bug/1554806/ + `requires` File.notPresent "/etc/localtime" diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs @@ -53,12 +53,20 @@ named n = configured [("Nickname", n')] where n' = saneNickname n +-- | Configures tor with secret_id_key, ed25519_master_id_public_key, +-- and ed25519_master_id_secret_key from privdata. torPrivKey :: Context -> Property (HasInfo + DebianLike) -torPrivKey context = f `File.hasPrivContent` context - `onChange` File.ownerGroup f user (userGroup user) +torPrivKey context = mconcat (map go keyfiles) + `onChange` restarted `requires` torPrivKeyDirExists where - f = torPrivKeyDir </> "secret_id_key" + keyfiles = map (torPrivKeyDir </>) + [ "secret_id_key" + , "ed25519_master_id_public_key" + , "ed25519_master_id_secret_key" + ] + go f = f `File.hasPrivContent` context + `onChange` File.ownerGroup f user (userGroup user) torPrivKeyDirExists :: Property DebianLike torPrivKeyDirExists = File.dirExists torPrivKeyDir @@ -124,22 +132,30 @@ bandwidthRate' s divby = case readSize dataUnits s of -- If used without `hiddenServiceData`, tor will generate a new -- private key. hiddenService :: HiddenServiceName -> Port -> Property DebianLike -hiddenService hn (Port port) = ConfFile.adjustSection - (unwords ["hidden service", hn, "available on port", show port]) +hiddenService hn port = hiddenService' hn [port] + +hiddenService' :: HiddenServiceName -> [Port] -> Property DebianLike +hiddenService' hn ports = ConfFile.adjustSection + (unwords ["hidden service", hn, "available on ports", intercalate "," (map val ports')]) (== oniondir) (not . isPrefixOf "HiddenServicePort") - (const [oniondir, onionport]) - (++ [oniondir, onionport]) + (const (oniondir : onionports)) + (++ oniondir : onionports) mainConfig `onChange` restarted where oniondir = unwords ["HiddenServiceDir", varLib </> hn] - onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port] + onionports = map onionport ports' + ports' = sort ports + onionport port = unwords ["HiddenServicePort", val port, "127.0.0.1:" ++ val port] -- | Same as `hiddenService` but also causes propellor to display -- the onion address of the hidden service. hiddenServiceAvailable :: HiddenServiceName -> Port -> Property DebianLike -hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port +hiddenServiceAvailable hn port = hiddenServiceAvailable' hn [port] + +hiddenServiceAvailable' :: HiddenServiceName -> [Port] -> Property DebianLike +hiddenServiceAvailable' hn ports = hiddenServiceHostName $ hiddenService' hn ports where hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs @@ -133,10 +133,10 @@ genAddress dom ttl addr = case addr of IPv6 _ -> genAddress' "AAAA" dom ttl addr genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String -genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> show ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ fromIPAddr addr +genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> val ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ val addr genMX :: BindDomain -> Int -> BindDomain -> String -genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ show priority ++ " " ++ dValue dest +genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ val priority ++ " " ++ dValue dest genPTR :: BindDomain -> ReverseIP -> String genPTR dom revip = revip ++ ". " ++ "PTR" ++ " " ++ dValue dom diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs @@ -22,17 +22,18 @@ systemAccountFor :: User -> Property DebianLike systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u)) systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike -systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go +systemAccountFor' (User u) mhome mgroup = case mgroup of + Nothing -> prop + Just g -> prop + `requires` systemGroup g `describe` ("system account for " ++ u) where + prop = tightenTargets $ check nouser go nouser = isNothing <$> catchMaybeIO (getUserEntryForName u) go = cmdProperty "adduser" $ - [ "--system" ] + [ "--system", "--home" ] ++ - "--home" : maybe - ["/nonexistent", "--no-create-home"] - ( \h -> [ h ] ) - mhome + maybe ["/nonexistent", "--no-create-home"] ( \h -> [h] ) mhome ++ maybe [] ( \(Group g) -> ["--ingroup", g] ) mgroup ++ @@ -42,8 +43,18 @@ systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go , u ] +systemGroup :: Group -> Property UnixLike +systemGroup (Group g) = check nogroup go + `describe` ("system account for " ++ g) + where + nogroup = isNothing <$> catchMaybeIO (getGroupEntryForName g) + go = cmdProperty "addgroup" + [ "--system" + , g + ] + -- | Removes user home directory!! Use with caution. -nuked :: User -> Eep -> Property DebianLike +nuked :: User -> Eep -> Property Linux nuked user@(User u) _ = tightenTargets $ check hashomedir go `describe` ("nuked user " ++ u) where @@ -97,8 +108,12 @@ setPassword getpassword = getpassword $ go -- | Makes a user's password be the passed String. Highly insecure: -- The password is right there in your config file for anyone to see! hasInsecurePassword :: User -> String -> Property DebianLike -hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $ - chpasswd u p [] +hasInsecurePassword u@(User n) p = go + `requires` shadowConfig True + where + go :: Property DebianLike + go = property (n ++ " has insecure password") $ + chpasswd u p [] chpasswd :: User -> String -> [String] -> Propellor Result chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess @@ -107,7 +122,7 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc hClose h lockedPassword :: User -> Property DebianLike -lockedPassword user@(User u) = tightenTargets $ +lockedPassword user@(User u) = tightenTargets $ check (not <$> isLockedPassword user) go `describe` ("locked " ++ u ++ " password") where diff --git a/src/Propellor/Property/Versioned.hs b/src/Propellor/Property/Versioned.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-} + +-- | Versioned properties and hosts. +-- +-- When importing and using this module, you will need to enable some +-- language extensions: +-- +-- > {-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-} +-- +-- This module takes advantage of `RevertableProperty` to let propellor +-- switch cleanly between versions. The way it works is all revertable +-- properties for other versions than the current version are first +-- reverted, and then propellor ensures the property for the current +-- version. This method should work for any combination of revertable +-- properties. +-- +-- For example: +-- +-- > demo :: Versioned Int (RevertableProperty DebianLike DebianLike) +-- > demo ver = +-- > ver ( (== 1) --> Apache.modEnabled "foo" +-- > `requires` Apache.modEnabled "foosupport" +-- > <|> (== 2) --> Apache.modEnabled "bar" +-- > <|> (> 2) --> Apache.modEnabled "baz" +-- > ) +-- > +-- > foo :: Host +-- > foo = host "foo.example.com" $ props +-- > & demo `version` (2 :: Int) +-- +-- Similarly, a whole Host can be versioned. For example: +-- +-- > bar :: Versioned Int Host +-- > bar ver = host "bar.example.com" $ props +-- > & osDebian Unstable X86_64 +-- > & ver ( (== 1) --> Apache.modEnabled "foo" +-- > <|> (== 2) --> Apache.modEnabled "bar" +-- > ) +-- > & ver ( (>= 2) --> Apt.unattendedUpgrades ) +-- +-- Note that some versioning of revertable properties may cause +-- propellor to do a lot of unnecessary work each time it's run. +-- Here's an example of such a problem: +-- +-- > slow :: Versioned Int -> RevertableProperty DebianLike DebianLike +-- > slow ver = +-- > ver ( (== 1) --> (Apt.installed "foo" <!> Apt.removed "foo") +-- > <|> (== 2) --> (Apt.installed "bar" <!> Apt.removed "bar") +-- > ) +-- +-- Suppose that package bar depends on package foo. Then at version 2, +-- propellor will remove package foo in order to revert version 1, only +-- to re-install it since version 2 also needs it installed. + +module Propellor.Property.Versioned (Versioned, version, (-->), (<|>)) where + +import Propellor +import Propellor.Types.Core + +import Data.List + +-- | Something that has multiple versions of type `v`. +type Versioned v t = VersionedBy v -> t + +type VersionedBy v + = forall metatypes. Combines (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes) + => (CombinedType (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes) ~ RevertableProperty metatypes metatypes) + => (VerSpec v metatypes -> RevertableProperty metatypes metatypes) + +-- | Access a particular version of a Versioned value. +version :: (Versioned v t) -> v -> t +version f v = f (processVerSpec v) + +-- A specification of versions. +-- +-- Why is this not a simple list like +-- [(v -> Bool, RevertableProperty metatypes metatypes)] ? +-- Using a list would mean the empty list would need to be dealt with, +-- and processVerSpec does not have a Monoid instance for +-- RevertableProperty metatypes metatypes in scope, and due to the way the +-- Versioned type works, the compiler cannot find such an instance. +-- +-- Also, using this data type allows a nice syntax for creating +-- VerSpecs, via the `<&>` and `alt` functions. +data VerSpec v metatypes + = Base (v -> Bool, RevertableProperty metatypes metatypes) + | More (v -> Bool, RevertableProperty metatypes metatypes) (VerSpec v metatypes) + +processVerSpec + :: Combines (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes) + => (CombinedType (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes) ~ RevertableProperty metatypes metatypes) + => v + -> VerSpec v metatypes + -> RevertableProperty metatypes metatypes +processVerSpec v s = combinedp s + `describe` intercalate " and " (combineddesc s []) + where + combinedp (Base (c, p)) + | c v = p + | otherwise = revert p + combinedp (More (c, p) vs) + | c v = combinedp vs `before` p + | otherwise = revert p `before` combinedp vs + combineddesc (Base (c, p)) l + | c v = getDesc p : l + | otherwise = getDesc (revert p) : l + combineddesc (More (c, p) vs) l + | c v = getDesc p : combineddesc vs l + | otherwise = getDesc (revert p) : combineddesc vs l + +-- | Specify a function that checks the version, and what +-- `RevertableProperty` to use if the version matches. +(-->) :: (v -> Bool) -> RevertableProperty metatypes metatypes -> VerSpec v metatypes +c --> p = Base (c, p) + +-- | Add an alternate version. +(<|>) :: VerSpec v metatypes -> VerSpec v metatypes -> VerSpec v metatypes +Base a <|> Base b = More a (Base b) +Base a <|> More b c = More a (More b c) +More b c <|> Base a = More a (More b c) +More a b <|> More c d = More a (More c (b <|> d)) + +infixl 8 --> +infixl 2 <|> diff --git a/src/Propellor/Property/XFCE.hs b/src/Propellor/Property/XFCE.hs @@ -0,0 +1,41 @@ +module Propellor.Property.XFCE where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.User as User + +installed :: Property DebianLike +installed = Apt.installed ["task-xfce-desktop"] + `describe` "XFCE desktop installed" + +-- | Minimal install of XFCE, with a terminal emulator and panel, +-- and X and network-manager, but not any of the extra apps. +installedMin :: Property DebianLike +installedMin = Apt.installedMin ["xfce4", "xfce4-terminal", "task-desktop"] + `describe` "minimal XFCE desktop installed" + +-- | Installs network-manager-gnome, which is the way to get +-- network-manager to manage networking in XFCE too. +networkManager :: Property DebianLike +networkManager = Apt.installedMin ["network-manager-gnome"] + +-- | Normally at first login, XFCE asks what kind of panel the user wants. +-- This enables the default configuration noninteractively. +defaultPanelFor :: User -> File.Overwrite -> Property DebianLike +defaultPanelFor u@(User username) overwrite = property' desc $ \w -> do + home <- liftIO $ User.homedir u + ensureProperty w (go home) + where + desc = "default XFCE panel for " ++ username + basecf = ".config" </> "xfce4" </> "xfconf" + </> "xfce-perchannel-xml" </> "xfce4-panel.xml" + -- This location is probably Debian-specific. + defcf = "/etc/xdg/xfce4/panel/default.xml" + go :: FilePath -> Property DebianLike + go home = tightenTargets $ + File.checkOverwrite overwrite (home </> basecf) $ \cf -> + cf `File.isCopyOf` defcf + `before` File.applyPath home basecf + (\f -> File.ownerGroup f u (userGroup u)) + `requires` Apt.installed ["xfce4-panel"] diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs @@ -5,7 +5,8 @@ module Propellor.Property.ZFS.Process where import Propellor.Base -import Data.String.Utils (split) +import Utility.Split + import Data.List -- | Gets the properties of a ZFS volume. diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs @@ -9,7 +9,6 @@ module Propellor.Shim (setup, cleanEnv, file) where import Propellor.Base import Utility.LinuxMkLibs import Utility.FileMode -import Utility.FileSystemEncoding import Data.List import System.Posix.Files @@ -57,7 +56,6 @@ shebang = "#!/bin/sh" checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath checkAlreadyShimmed f nope = ifM (doesFileExist f) ( withFile f ReadMode $ \h -> do - fileEncoding h s <- hGetLine h if s == shebang then return f diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs @@ -87,12 +87,15 @@ spin' mprivdata relay target hst = do -- And now we can run it. unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ - error "remote propellor failed" + giveup "remote propellor failed" where hn = fromMaybe target relay sys = case fromInfo (hostInfo hst) of InfoVal o -> Just o NoInfoVal -> Nothing + bootstrapper = case fromInfo (hostInfo hst) of + NoInfoVal -> defaultBootstrapper + InfoVal bs -> bs relaying = relay == Just target viarelay = isJust relay && not relaying @@ -109,7 +112,7 @@ spin' mprivdata relay target hst = do updatecmd = intercalate " && " [ "cd " ++ localdir - , bootstrapPropellorCommand sys + , bootstrapPropellorCommand bootstrapper sys , if viarelay then "./propellor --continue " ++ shellEscape (show (Relay target)) @@ -169,7 +172,7 @@ getSshTarget target hst warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead." return ip - configips = map fromIPAddr $ mapMaybe getIPAddr $ + configips = map val $ mapMaybe getIPAddr $ S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst -- Update the privdata, repo url, and git repo over the ssh @@ -186,26 +189,8 @@ update forhost = do writeFileProtected privfile whenM hasGitRepo $ - req NeedGitPush gitPushMarker $ \_ -> do - hin <- dup stdInput - hout <- dup stdOutput - hClose stdin - hClose stdout - -- Not using git pull because git 2.5.0 badly - -- broke its option parser. - unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $ - errorMessage "git fetch from client failed" - unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $ - errorMessage "git merge from client failed" + gitPullFromUpdateServer where - pullparams hin hout = - [ Param "fetch" - , Param "--progress" - , Param "--upload-pack" - , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout - , Param "." - ] - -- When --spin --relay is run, get a privdata file -- to be relayed to the target host. privfile = maybe privDataLocal privDataRelay forhost @@ -336,31 +321,6 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor , "rm -f " ++ remotetarball ] --- Shim for git push over the propellor ssh channel. --- Reads from stdin and sends it to hout; --- reads from hin and sends it to stdout. -gitPushHelper :: Fd -> Fd -> IO () -gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout - where - fromstdin = do - h <- fdToHandle hout - connect stdin h - tostdout = do - h <- fdToHandle hin - connect h stdout - connect fromh toh = do - hSetBinaryMode fromh True - hSetBinaryMode toh True - b <- B.hGetSome fromh 40960 - if B.null b - then do - hClose fromh - hClose toh - else do - B.hPut toh b - hFlush toh - connect fromh toh - mergeSpin :: IO () mergeSpin = do branch <- getCurrentBranch @@ -388,3 +348,68 @@ findLastNonSpinCommit = do spinCommitMessage :: String spinCommitMessage = "propellor spin" + +-- Stdin and stdout are connected to the updateServer over ssh. +-- Request that it run git upload-pack, and connect that up to a git fetch +-- to receive the data. +gitPullFromUpdateServer :: IO () +gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do + -- IO involving stdin can cause data to be buffered in the Handle + -- (even when it's set NoBuffering), but we need to pass a FD to + -- git fetch containing all of stdin after the gitPushMarker, + -- including any that has been buffered. + -- + -- To do so, create a pipe, and forward stdin, including any + -- buffered part, through it. + (pread, pwrite) <- System.Posix.IO.createPipe + -- Note that there is a race between the createPipe and setting + -- CloseOnExec. Another processess forked here would inherit + -- pwrite and perhaps keep it open. However, propellor is not + -- running concurrent threads at this point, so this is ok. + setFdOption pwrite CloseOnExec True + hwrite <- fdToHandle pwrite + forwarder <- async $ stdin *>* hwrite + let hin = pread + hout <- dup stdOutput + hClose stdout + -- Not using git pull because git 2.5.0 badly + -- broke its option parser. + unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $ + errorMessage "git fetch from client failed" + wait forwarder + unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $ + errorMessage "git merge from client failed" + where + fetchparams hin hout = + [ Param "fetch" + , Param "--progress" + , Param "--upload-pack" + , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout + , Param "." + ] + +-- Shim for git push over the propellor ssh channel. +-- Reads from stdin and sends it to hout; +-- reads from hin and sends it to stdout. +gitPushHelper :: Fd -> Fd -> IO () +gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout + where + fromstdin = do + h <- fdToHandle hout + stdin *>* h + tostdout = do + h <- fdToHandle hin + h *>* stdout + +-- Forward data from one handle to another. +(*>*) :: Handle -> Handle -> IO () +fromh *>* toh = do + b <- B.hGetSome fromh 40960 + if B.null b + then do + hClose fromh + hClose toh + else do + B.hPut toh b + hFlush toh + fromh *>* toh diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs @@ -6,7 +6,7 @@ import Utility.FileSystemEncoding import System.PosixCompat import Data.Time.Clock.POSIX -import qualified Data.Hash.MD5 as MD5 +import Data.Hashable -- Parameters can be passed to both ssh and scp, to enable a ssh connection -- caching socket. @@ -50,24 +50,22 @@ sshCachingParams hn = do -- 100 bytes. Try to never construct a filename longer than that. -- -- When space allows, include the full hostname in the socket filename. --- Otherwise, include at least a partial md5sum of it, --- to avoid using the same socket file for multiple hosts. +-- Otherwise, a checksum of the hostname is included in the name, to +-- avoid using the same socket file for multiple hosts. socketFile :: FilePath -> HostName -> FilePath socketFile home hn = selectSocketFile - [ sshdir </> hn ++ ".sock" + [ sshdir </> hn ++ ".sock" , sshdir </> hn - , sshdir </> take 10 hn ++ "-" ++ md5 - , sshdir </> md5 - , home </> ".propellor-" ++ md5 + , sshdir </> take 10 hn ++ "-" ++ checksum + , sshdir </> checksum ] - (".propellor-" ++ md5) + (home </> ".propellor-" ++ checksum) where sshdir = home </> ".ssh" </> "propellor" - md5 = take 9 $ MD5.md5s $ MD5.Str hn + checksum = take 9 $ show $ abs $ hash hn selectSocketFile :: [FilePath] -> FilePath -> FilePath selectSocketFile [] d = d -selectSocketFile [f] _ = f selectSocketFile (f:fs) d | valid_unix_socket_path f = f | otherwise = selectSocketFile fs d diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs @@ -12,6 +12,7 @@ module Propellor.Types ( Host(..) , Property(..) , property + , property'' , Desc , RevertableProperty(..) , (<!>) @@ -24,6 +25,7 @@ module Propellor.Types ( , DebianLike , Debian , Buntish + , ArchLinux , FreeBSD , HasInfo , type (+) @@ -35,16 +37,20 @@ module Propellor.Types ( , adjustPropertySatisfy -- * Other included types , module Propellor.Types.OS + , module Propellor.Types.ConfigurableValue , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS ) where import Data.Monoid +import Control.Applicative +import Prelude import Propellor.Types.Core import Propellor.Types.Info import Propellor.Types.OS +import Propellor.Types.ConfigurableValue import Propellor.Types.Dns import Propellor.Types.Result import Propellor.Types.MetaTypes @@ -53,7 +59,6 @@ import Propellor.Types.ZFS -- | The core data type of Propellor, this represents a property -- that the system should have, with a descrition, and an action to ensure -- it has the property. --- that have the property. -- -- There are different types of properties that target different OS's, -- and so have different metatypes. @@ -64,7 +69,7 @@ import Propellor.Types.ZFS -- -- There are many associated type families, which are mostly used -- internally, so you needn't worry about them. -data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] +data Property metatypes = Property metatypes Desc (Maybe (Propellor Result)) Info [ChildProperty] instance Show (Property metatypes) where show p = "property " ++ show (getDesc p) @@ -87,14 +92,25 @@ property => Desc -> Propellor Result -> Property (MetaTypes metatypes) -property d a = Property sing d a mempty mempty +property d a = Property sing d (Just a) mempty mempty + +property'' + :: SingI metatypes + => Desc + -> Maybe (Propellor Result) + -> Property (MetaTypes metatypes) +property'' d a = Property sing d a mempty mempty -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes -adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c +adjustPropertySatisfy (Property t d s i c) f = Property t d (f <$> s) i c -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. +-- +-- See `Propellor.Property.Versioned.Versioned` +-- for a way to use RevertableProperty to define different +-- versions of a host. data RevertableProperty setupmetatypes undometatypes = RevertableProperty { setupRevertableProperty :: Property setupmetatypes , undoRevertableProperty :: Property undometatypes @@ -145,7 +161,7 @@ type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Re type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y)) type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y)) -type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result +type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (Propellor Result) class Combines x y where -- | Combines together two properties, yielding a property that @@ -195,3 +211,35 @@ class TightenTargets p where instance TightenTargets Property where tightenTargets (Property _ d a i c) = Property sing d a i c + +-- | Any type of Property is a monoid. When properties x and y are +-- appended together, the resulting property has a description like +-- "x and y". Note that when x fails to be ensured, it will not +-- try to ensure y. +instance SingI metatypes => Monoid (Property (MetaTypes metatypes)) + where + mempty = Property sing "noop property" Nothing mempty mempty + mappend (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) = + Property sing d (a1 <> a2) (i1 <> i2) (c1 <> c2) + where + -- Avoid including "noop property" in description + -- when using eg mconcat. + d = case (a1, a2) of + (Just _, Just _) -> d1 <> " and " <> d2 + (Just _, Nothing) -> d1 + (Nothing, Just _) -> d2 + (Nothing, Nothing) -> d1 + +-- | Any type of RevertableProperty is a monoid. When revertable +-- properties x and y are appended together, the resulting revertable +-- property has a description like "x and y". +-- Note that when x fails to be ensured, it will not try to ensure y. +instance + ( Monoid (Property setupmetatypes) + , Monoid (Property undometatypes) + ) + => Monoid (RevertableProperty setupmetatypes undometatypes) + where + mempty = RevertableProperty mempty mempty + mappend (RevertableProperty s1 u1) (RevertableProperty s2 u2) = + RevertableProperty (s1 <> s2) (u2 <> u1) diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-} + +module Propellor.Types.Bootloader where + +import Propellor.Types.Info + +-- | Boot loader installed on a host. +data BootloaderInstalled = GrubInstalled + deriving (Typeable, Show) + +instance IsInfo [BootloaderInstalled] where + propagateInfo _ = PropagateInfo False diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs @@ -16,7 +16,7 @@ data ChrootInfo = ChrootInfo deriving (Show, Typeable) instance IsInfo ChrootInfo where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False instance Monoid ChrootInfo where mempty = ChrootInfo mempty mempty diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs @@ -28,4 +28,5 @@ data CmdLine | ChrootChain HostName FilePath Bool Bool | GitPush Fd Fd | Check + | Build deriving (Read, Show, Eq) diff --git a/src/Propellor/Types/ConfigurableValue.hs b/src/Propellor/Types/ConfigurableValue.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Propellor.Types.ConfigurableValue where + +import Data.Word + +-- | A value that can be used in a configuration file, or otherwise used to +-- configure a program. +-- +-- Unlike Show, there should only be instances of this type class for +-- values that have a standard serialization that is understood outside of +-- Haskell code. +-- +-- When converting a type alias such as "type Foo = String" or "type Foo = Int" +-- to a newtype, it's unsafe to derive a Show instance, because there may +-- be code that shows the type to configure a value. Instead, define a +-- ConfigurableValue instance. +class ConfigurableValue t where + val :: t -> String + +-- | val String does not do any quoting, unlike show String +instance ConfigurableValue String where + val = id + +instance ConfigurableValue Int where + val = show + +instance ConfigurableValue Integer where + val = show + +instance ConfigurableValue Float where + val = show + +instance ConfigurableValue Double where + val = show + +instance ConfigurableValue Word8 where + val = show + +instance ConfigurableValue Word16 where + val = show + +instance ConfigurableValue Word32 where + val = show diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs @@ -48,9 +48,10 @@ instance LiftPropellor Propellor where instance LiftPropellor IO where liftPropellor = liftIO +-- | When two actions are appended together, the second action +-- is only run if the first action does not fail. instance Monoid (Propellor Result) where mempty = return NoChange - -- | The second action is only run if the first action does not fail. mappend x y = do rx <- x case rx of @@ -71,7 +72,7 @@ data Props metatypes = Props [ChildProperty] -- | Since there are many different types of Properties, they cannot be put -- into a list. The simplified ChildProperty can be put into a list. -data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] +data ChildProperty = ChildProperty Desc (Maybe (Propellor Result)) Info [ChildProperty] instance Show ChildProperty where show p = "property " ++ show (getDesc p) @@ -92,7 +93,7 @@ class IsProp p where -- | Gets the action that can be run to satisfy a Property. -- You should never run this action directly. Use -- 'Propellor.EnsureProperty.ensureProperty` instead. - getSatisfy :: p -> Propellor Result + getSatisfy :: p -> Maybe (Propellor Result) instance IsProp ChildProperty where setDesc (ChildProperty _ a i c) d = ChildProperty d a i c diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs @@ -5,12 +5,13 @@ module Propellor.Types.Dns where import Propellor.Types.OS (HostName) import Propellor.Types.Empty import Propellor.Types.Info +import Propellor.Types.ConfigurableValue +import Utility.Split import Data.Word import qualified Data.Map as M import qualified Data.Set as S import Data.List -import Data.String.Utils (split, replace) import Data.Monoid import Prelude @@ -19,15 +20,15 @@ type Domain = String data IPAddr = IPv4 String | IPv6 String deriving (Read, Show, Eq, Ord) -fromIPAddr :: IPAddr -> String -fromIPAddr (IPv4 addr) = addr -fromIPAddr (IPv6 addr) = addr +instance ConfigurableValue IPAddr where + val (IPv4 addr) = addr + val (IPv6 addr) = addr newtype AliasesInfo = AliasesInfo (S.Set HostName) deriving (Show, Eq, Ord, Monoid, Typeable) instance IsInfo AliasesInfo where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False toAliasesInfo :: [HostName] -> AliasesInfo toAliasesInfo l = AliasesInfo (S.fromList l) @@ -44,7 +45,7 @@ toDnsInfo = DnsInfo -- | DNS Info is propagated, so that eg, aliases of a container -- are reflected in the dns for the host where it runs. instance IsInfo DnsInfo where - propagateInfo _ = True + propagateInfo _ = PropagateInfo True -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf @@ -101,14 +102,14 @@ data Record type ReverseIP = String reverseIP :: IPAddr -> ReverseIP -reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa" -reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ fromIPAddr $ canonicalIP addr) ++ ".ip6.arpa" +reverseIP (IPv4 addr) = intercalate "." (reverse $ splitc '.' addr) ++ ".in-addr.arpa" +reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa" -- | Converts an IP address (particularly IPv6) to canonical, fully -- expanded form. canonicalIP :: IPAddr -> IPAddr canonicalIP (IPv4 addr) = IPv4 addr -canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr +canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ splitc ':' $ replaceImplicitGroups addr where canonicalGroup g | l <= 4 = replicate (4 - l) '0' ++ g @@ -116,7 +117,7 @@ canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ": where l = length g emptyGroups n = iterate (++ ":") "" !! n - numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a) + numberOfImplicitGroups a = 8 - length (splitc ':' $ replace "::" "" a) replaceImplicitGroups a = concat $ aux $ split "::" a where aux [] = [] @@ -156,7 +157,7 @@ newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf) deriving (Eq, Ord, Show, Typeable) instance IsInfo NamedConfMap where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs @@ -16,7 +16,7 @@ data DockerInfo = DockerInfo deriving (Show, Typeable) instance IsInfo DockerInfo where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False instance Monoid DockerInfo where mempty = DockerInfo mempty mempty diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs @@ -1,13 +1,14 @@ {-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Propellor.Types.Info ( - Info, + Info(..), + InfoEntry(..), IsInfo(..), + PropagateInfo(..), addInfo, toInfo, fromInfo, mapInfo, - propagatableInfo, InfoVal(..), fromInfoVal, Typeable, @@ -16,6 +17,7 @@ module Propellor.Types.Info ( import Data.Dynamic import Data.Maybe import Data.Monoid +import qualified Data.Typeable as T import Prelude -- | Information about a Host, which can be provided by its properties. @@ -34,7 +36,7 @@ instance Show InfoEntry where -- Extracts the value from an InfoEntry but only when -- it's of the requested type. extractInfoEntry :: Typeable v => InfoEntry -> Maybe v -extractInfoEntry (InfoEntry v) = cast v +extractInfoEntry (InfoEntry v) = T.cast v -- | Values stored in Info must be members of this class. -- @@ -44,7 +46,13 @@ extractInfoEntry (InfoEntry v) = cast v class (Typeable v, Monoid v, Show v) => IsInfo v where -- | Should info of this type be propagated out of a -- container to its Host? - propagateInfo :: v -> Bool + propagateInfo :: v -> PropagateInfo + +data PropagateInfo + = PropagateInfo Bool + | PropagatePrivData + -- ^ Info about PrivData generally will be propigated even in cases + -- where other Info is not, so it treated specially. -- | Any value in the `IsInfo` type class can be added to an Info. addInfo :: IsInfo v => Info -> v -> Info @@ -68,11 +76,6 @@ mapInfo f (Info l) = Info (map go l) Nothing -> i Just v -> InfoEntry (f v) --- | Filters out parts of the Info that should not propagate out of a --- container. -propagatableInfo :: Info -> Info -propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l) - -- | Use this to put a value in Info that is not a monoid. -- The last value set will be used. This info does not propagate -- out of a container. @@ -85,7 +88,7 @@ instance Monoid (InfoVal v) where mappend v NoInfoVal = v instance (Typeable v, Show v) => IsInfo (InfoVal v) where - propagateInfo _ = False + propagateInfo _ = PropagateInfo False fromInfoVal :: InfoVal v -> Maybe v fromInfoVal NoInfoVal = Nothing diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs @@ -7,6 +7,7 @@ module Propellor.Types.MetaTypes ( DebianLike, Debian, Buntish, + ArchLinux, FreeBSD, HasInfo, MetaTypes, @@ -35,14 +36,26 @@ data MetaType deriving (Show, Eq, Ord) -- | Any unix-like system -type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] +type UnixLike = MetaTypes + '[ 'Targeting 'OSDebian + , 'Targeting 'OSBuntish + , 'Targeting 'OSArchLinux + , 'Targeting 'OSFreeBSD + ] + -- | Any linux system -type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] +type Linux = MetaTypes + '[ 'Targeting 'OSDebian + , 'Targeting 'OSBuntish + , 'Targeting 'OSArchLinux + ] + -- | Debian and derivatives. type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] type Debian = MetaTypes '[ 'Targeting 'OSDebian ] type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] +type ArchLinux = MetaTypes '[ 'Targeting 'OSArchLinux ] -- | Used to indicate that a Property adds Info to the Host where it's used. type HasInfo = MetaTypes '[ 'WithInfo ] @@ -58,16 +71,19 @@ data instance Sing (x :: MetaType) where OSDebianS :: Sing ('Targeting 'OSDebian) OSBuntishS :: Sing ('Targeting 'OSBuntish) OSFreeBSDS :: Sing ('Targeting 'OSFreeBSD) + OSArchLinuxS :: Sing ('Targeting 'OSArchLinux) WithInfoS :: Sing 'WithInfo instance SingI ('Targeting 'OSDebian) where sing = OSDebianS instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS +instance SingI ('Targeting 'OSArchLinux) where sing = OSArchLinuxS instance SingI 'WithInfo where sing = WithInfoS instance SingKind ('KProxy :: KProxy MetaType) where type DemoteRep ('KProxy :: KProxy MetaType) = MetaType fromSing OSDebianS = Targeting OSDebian fromSing OSBuntishS = Targeting OSBuntish fromSing OSFreeBSDS = Targeting OSFreeBSD + fromSing OSArchLinuxS = Targeting OSArchLinux fromSing WithInfoS = WithInfo -- | Convenience type operator to combine two `MetaTypes` lists. @@ -186,6 +202,14 @@ type instance EqT 'OSBuntish 'OSDebian = 'False type instance EqT 'OSBuntish 'OSFreeBSD = 'False type instance EqT 'OSFreeBSD 'OSDebian = 'False type instance EqT 'OSFreeBSD 'OSBuntish = 'False +type instance EqT 'OSArchLinux 'OSArchLinux = 'True +type instance EqT 'OSArchLinux 'OSDebian = 'False +type instance EqT 'OSArchLinux 'OSBuntish = 'False +type instance EqT 'OSArchLinux 'OSFreeBSD = 'False +type instance EqT 'OSDebian 'OSArchLinux = 'False +type instance EqT 'OSBuntish 'OSArchLinux = 'False +type instance EqT 'OSFreeBSD 'OSArchLinux = 'False + -- More modern version if the combinatiorial explosion gets too bad later: -- -- type family Eq (a :: MetaType) (b :: MetaType) where diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs @@ -18,10 +18,11 @@ module Propellor.Types.OS ( Group(..), userGroup, Port(..), - fromPort, systemToTargetOS, ) where +import Propellor.Types.ConfigurableValue + import Network.BSD (HostName) import Data.Typeable import Data.String @@ -33,6 +34,7 @@ data System = System Distribution Architecture data Distribution = Debian DebianKernel DebianSuite | Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/> + | ArchLinux | FreeBSD FreeBSDRelease deriving (Show, Eq) @@ -41,12 +43,14 @@ data Distribution data TargetOS = OSDebian | OSBuntish + | OSArchLinux | OSFreeBSD deriving (Show, Eq, Ord) systemToTargetOS :: System -> TargetOS systemToTargetOS (System (Debian _ _) _) = OSDebian systemToTargetOS (System (Buntish _) _) = OSBuntish +systemToTargetOS (System (ArchLinux) _) = OSArchLinux systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD -- | Most of Debian ports are based on Linux. There also exist hurd-i386, @@ -55,7 +59,7 @@ data DebianKernel = Linux | KFreeBSD | Hurd deriving (Show, Eq) -- | Debian has several rolling suites, and a number of stable releases, --- such as Stable "jessie". +-- such as Stable "stretch". data DebianSuite = Experimental | Unstable | Testing | Stable Release deriving (Show, Eq) @@ -72,10 +76,13 @@ instance IsString FBSDVersion where fromString "9.3-RELEASE" = FBSD093 fromString _ = error "Invalid FreeBSD release" +instance ConfigurableValue FBSDVersion where + val FBSD101 = "10.1-RELEASE" + val FBSD102 = "10.2-RELEASE" + val FBSD093 = "9.3-RELEASE" + instance Show FBSDVersion where - show FBSD101 = "10.1-RELEASE" - show FBSD102 = "10.2-RELEASE" - show FBSD093 = "9.3-RELEASE" + show = val isStable :: DebianSuite -> Bool isStable (Stable _) = True @@ -135,15 +142,21 @@ type UserName = String newtype User = User UserName deriving (Eq, Ord, Show) +instance ConfigurableValue User where + val (User n) = n + newtype Group = Group String deriving (Eq, Ord, Show) +instance ConfigurableValue Group where + val (Group n) = n + -- | Makes a Group with the same name as the User. userGroup :: User -> Group userGroup (User u) = Group u newtype Port = Port Int - deriving (Eq, Show) + deriving (Eq, Ord, Show) -fromPort :: Port -> String -fromPort (Port p) = show p +instance ConfigurableValue Port where + val (Port p) = show p diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs @@ -0,0 +1,66 @@ +-- | 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) + +-- | Default partition size when not otherwize specified is 128 MegaBytes. +defSz :: PartSize +defSz = MegaBytes 128 diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs @@ -24,6 +24,9 @@ instance ToResult Bool where toResult False = FailedChange toResult True = MadeChange +instance ToResult Result where + toResult = id + -- | Results of actions, with color. class ActionResult a where getActionResult :: a -> (String, ColorIntensity, Color) diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs @@ -6,9 +6,11 @@ module Propellor.Types.ZFS where +import Propellor.Types.ConfigurableValue +import Utility.Split + import Data.String import qualified Data.Set as Set -import qualified Data.String.Utils as SU import Data.List -- | A single ZFS filesystem. @@ -32,24 +34,27 @@ toPropertyList = Set.foldr (\p l -> l ++ [toPair p]) [] fromPropertyList :: [(String, String)] -> ZFSProperties fromPropertyList props = - Set.fromList $ map fromPair props + Set.fromList $ map fromPair props zfsName :: ZFS -> String zfsName (ZFS (ZPool pool) dataset) = intercalate "/" [pool, show dataset] +instance ConfigurableValue ZDataset where + val (ZDataset paths) = intercalate "/" paths + instance Show ZDataset where - show (ZDataset paths) = intercalate "/" paths + show = val instance IsString ZDataset where - fromString s = ZDataset $ SU.split "/" s + fromString s = ZDataset $ splitc '/' s instance IsString ZPool where - fromString p = ZPool p + fromString p = ZPool p class Value a where - toValue :: a -> String - fromValue :: (IsString a) => String -> a - fromValue = fromString + toValue :: a -> String + fromValue :: (IsString a) => String -> a + fromValue = fromString data ZFSYesNo = ZFSYesNo Bool deriving (Show, Eq, Ord) data ZFSOnOff = ZFSOnOff Bool deriving (Show, Eq, Ord) @@ -57,57 +62,57 @@ data ZFSSize = ZFSSize Integer deriving (Show, Eq, Ord) data ZFSString = ZFSString String deriving (Show, Eq, Ord) instance Value ZFSYesNo where - toValue (ZFSYesNo True) = "yes" - toValue (ZFSYesNo False) = "no" + toValue (ZFSYesNo True) = "yes" + toValue (ZFSYesNo False) = "no" instance Value ZFSOnOff where - toValue (ZFSOnOff True) = "on" - toValue (ZFSOnOff False) = "off" + toValue (ZFSOnOff True) = "on" + toValue (ZFSOnOff False) = "off" instance Value ZFSSize where - toValue (ZFSSize s) = show s + toValue (ZFSSize s) = show s instance Value ZFSString where - toValue (ZFSString s) = s + toValue (ZFSString s) = s instance IsString ZFSString where - fromString = ZFSString + fromString = ZFSString instance IsString ZFSYesNo where - fromString "yes" = ZFSYesNo True - fromString "no" = ZFSYesNo False - fromString _ = error "Not yes or no" + fromString "yes" = ZFSYesNo True + fromString "no" = ZFSYesNo False + fromString _ = error "Not yes or no" instance IsString ZFSOnOff where - fromString "on" = ZFSOnOff True - fromString "off" = ZFSOnOff False - fromString _ = error "Not on or off" + fromString "on" = ZFSOnOff True + fromString "off" = ZFSOnOff False + fromString _ = error "Not on or off" data ZFSACLInherit = AIDiscard | AINoAllow | AISecure | AIPassthrough deriving (Show, Eq, Ord) instance IsString ZFSACLInherit where - fromString "discard" = AIDiscard - fromString "noallow" = AINoAllow - fromString "secure" = AISecure - fromString "passthrough" = AIPassthrough - fromString _ = error "Not valid aclpassthrough value" + fromString "discard" = AIDiscard + fromString "noallow" = AINoAllow + fromString "secure" = AISecure + fromString "passthrough" = AIPassthrough + fromString _ = error "Not valid aclpassthrough value" instance Value ZFSACLInherit where - toValue AIDiscard = "discard" - toValue AINoAllow = "noallow" - toValue AISecure = "secure" - toValue AIPassthrough = "passthrough" + toValue AIDiscard = "discard" + toValue AINoAllow = "noallow" + toValue AISecure = "secure" + toValue AIPassthrough = "passthrough" data ZFSACLMode = AMDiscard | AMGroupmask | AMPassthrough deriving (Show, Eq, Ord) instance IsString ZFSACLMode where - fromString "discard" = AMDiscard - fromString "groupmask" = AMGroupmask - fromString "passthrough" = AMPassthrough - fromString _ = error "Invalid zfsaclmode" + fromString "discard" = AMDiscard + fromString "groupmask" = AMGroupmask + fromString "passthrough" = AMPassthrough + fromString _ = error "Invalid zfsaclmode" instance Value ZFSACLMode where - toValue AMDiscard = "discard" - toValue AMGroupmask = "groupmask" - toValue AMPassthrough = "passthrough" + toValue AMDiscard = "discard" + toValue AMGroupmask = "groupmask" + toValue AMPassthrough = "passthrough" data ZFSProperty = Mounted ZFSYesNo | Mountpoint ZFSString diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs @@ -45,6 +45,7 @@ module Utility.DataUnits ( ByteSize, roughSize, + roughSize', compareSizes, readSize ) where @@ -109,7 +110,10 @@ oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits {- approximate display of a particular number of bytes -} roughSize :: [Unit] -> Bool -> ByteSize -> String -roughSize units short i +roughSize units short i = roughSize' units short 2 i + +roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String +roughSize' units short precision i | i < 0 = '-' : findUnit units' (negate i) | otherwise = findUnit units' i where @@ -123,7 +127,7 @@ roughSize units short i showUnit x (Unit size abbrev name) = s ++ " " ++ unit where v = (fromInteger x :: Double) / fromInteger size - s = showImprecise 2 v + s = showImprecise precision v unit | short = abbrev | s == "1" = name diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess <id@joeyh.name> + - Copyright 2011-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Exception ( module X, + giveup, catchBoolIO, catchMaybeIO, catchDefaultIO, @@ -28,9 +29,11 @@ module Utility.Exception ( import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) -#if MIN_VERSION_base(4,7,0) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) import Control.Exception (SomeAsyncException) #endif +#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) @@ -38,6 +41,21 @@ import GHC.IO.Exception (IOErrorType(..)) import Utility.Data +{- Like error, this throws an exception. Unlike error, if this exception + - is not caught, it won't generate a backtrace. So use this for situations + - where there's a problem that the user is excpected to see in some + - circumstances. -} +giveup :: [Char] -> a +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,9,0) +giveup = errorWithoutStackTrace +#else +giveup = error +#endif +#else +giveup = error +#endif + {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False @@ -77,9 +95,11 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) -#if MIN_VERSION_base(4,7,0) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) , M.Handler (\ (e :: SomeAsyncException) -> throwM e) #endif +#endif , M.Handler (\ (e :: SomeException) -> onerr e) ] diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2017 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -130,6 +130,21 @@ withUmask umask a = bracket setup cleanup go withUmask _ a = a #endif +getUmask :: IO FileMode +#ifndef mingw32_HOST_OS +getUmask = bracket setup cleanup return + where + setup = setFileCreationMask nullFileMode + cleanup = setFileCreationMask +#else +getUmask = return nullFileMode +#endif + +defaultFileMode :: IO FileMode +defaultFileMode = do + umask <- getUmask + return $ intersectFileModes (complement umask) stdFileMode + combineModes :: [FileMode] -> FileMode combineModes [] = 0 combineModes [m] = m @@ -162,7 +177,10 @@ writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () -writeFileProtected' file writer = withUmask 0o0077 $ +writeFileProtected' file writer = protectedOutput $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h + +protectedOutput :: IO a -> IO a +protectedOutput = withUmask 0o0077 diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess <id@joeyh.name> + - Copyright 2012-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -9,9 +9,9 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( + useFileSystemEncoding, fileEncoding, withFilePath, - md5FilePath, decodeBS, encodeBS, decodeW8, @@ -19,7 +19,10 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, - setConsoleEncoding, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -27,29 +30,45 @@ import qualified GHC.IO.Encoding as Encoding import Foreign.C import System.IO import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 import Data.Word -import Data.Bits.Utils import Data.List -import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif import Utility.Exception +import Utility.Split -{- Sets a Handle to use the filesystem encoding. This causes data - - written or read from it to be encoded/decoded the same - - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". +{- Makes all subsequent Handles that are opened, as well as stdio Handles, + - use the filesystem encoding, instead of the encoding of the current + - locale. + - + - The filesystem encoding allows "arbitrary undecodable bytes to be + - round-tripped through it". This avoids encoded failures when data is not + - encoded matching the current locale. + - + - Note that code can still use hSetEncoding to change the encoding of a + - Handle. This only affects the default encoding. -} +useFileSystemEncoding :: IO () +useFileSystemEncoding = do +#ifndef mingw32_HOST_OS + e <- Encoding.getFileSystemEncoding +#else + {- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} + let e = Encoding.utf8 +#endif + hSetEncoding stdin e + hSetEncoding stdout e + hSetEncoding stderr e + Encoding.setLocaleEncoding e + fileEncoding :: Handle -> IO () #ifndef mingw32_HOST_OS fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding #else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} fileEncoding h = hSetEncoding h Encoding.utf8 #endif @@ -83,10 +102,6 @@ _encodeFilePath fp = unsafePerformIO $ do GHC.withCString enc fp (GHC.peekCString Encoding.char8) `catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -md5FilePath :: FilePath -> MD5.Str -md5FilePath = MD5.Str . _encodeFilePath - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS @@ -127,14 +142,26 @@ decodeW8 = s2w8 . _encodeFilePath {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) where - nul = ['\NUL'] + nul = '\NUL' decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where - nul = ['\NUL'] + nul = '\NUL' + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. @@ -165,10 +192,3 @@ truncateFilePath n = reverse . go [] n . L8.fromString else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif - -{- This avoids ghc's output layer crashing on invalid encoded characters in - - filenames when printing them out. -} -setConsoleEncoding :: IO () -setConsoleEncoding = do - fileEncoding stdout - fileEncoding stderr diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs @@ -12,10 +12,10 @@ import Utility.Directory import Utility.Process import Utility.Monad import Utility.Path +import Utility.Split import Data.Maybe import System.FilePath -import Data.List.Utils import System.Posix.Files import Data.Char import Control.Monad.IfElse diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs @@ -10,9 +10,6 @@ module Utility.Misc where -import Utility.FileSystemEncoding -import Utility.Monad - import System.IO import Control.Monad import Foreign @@ -35,20 +32,6 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{- Reads a file strictly, and using the FileSystemEncoding, so it will - - never crash on a badly encoded file. -} -readFileStrictAnyEncoding :: FilePath -> IO String -readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do - fileEncoding h - hClose h `after` hGetContentsStrict h - -{- Writes a file, using the FileSystemEncoding so it will never crash - - on a badly encoded content string. -} -writeFileAnyEncoding :: FilePath -> String -> IO () -writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do - fileEncoding h - hPutStr h content - {- Like break, but the item matching the condition is not included - in the second result list. - diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs @@ -2,7 +2,7 @@ - bugs. - - This exports functions that conflict with the prelude, which avoids - - them being accidentially used. + - them being accidentally used. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs @@ -10,7 +10,6 @@ module Utility.Path where -import Data.String.Utils import System.FilePath import Data.List import Data.Maybe @@ -25,10 +24,10 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory +import Utility.Split {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -89,12 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs where - -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + -- on Unix, the drive will be "/" when the dir is absolute, + -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . null) $ split s path s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -149,11 +137,11 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto @@ -227,6 +215,8 @@ inPath command = isJust <$> searchPath command - - The command may be fully qualified already, in which case it will - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. -} searchPath :: String -> IO (Maybe FilePath) searchPath command diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs @@ -174,22 +174,21 @@ createBackgroundProcess p a = a =<< createProcess p -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript = processTranscript' id +processTranscript cmd opts = processTranscript' (proc cmd opts) -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) -processTranscript' modproc cmd opts input = do +processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) +processTranscript' cp input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} (readf, writef) <- System.Posix.IO.createPipe readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } hClose writeh get <- mkreader readh @@ -200,12 +199,11 @@ processTranscript' modproc cmd opts input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p) diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs @@ -11,7 +11,7 @@ module Utility.SafeCommand where import System.Exit import Utility.Process -import Data.String.Utils +import Utility.Split import System.FilePath import Data.Char import Data.List @@ -86,7 +86,7 @@ shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ splitc '\'' f -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs @@ -29,6 +29,7 @@ module Utility.Scheduled ( import Utility.Data import Utility.PartialPrelude import Utility.Misc +import Utility.Tuple import Data.List import Data.Time.Clock @@ -37,7 +38,6 @@ import Data.Time.Calendar import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate import Data.Time.Format () -import Data.Tuple.Utils import Data.Char import Control.Applicative import Prelude diff --git a/src/Utility/Split.hs b/src/Utility/Split.hs @@ -0,0 +1,30 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Split where + +import Data.List (intercalate) +import Data.List.Split (splitOn) + +-- | same as Data.List.Utils.split +-- +-- intercalate x . splitOn x === id +split :: Eq a => [a] -> [a] -> [[a]] +split = splitOn + +-- | Split on a single character. This is over twice as fast as using +-- split on a list of length 1, while producing identical results. -} +splitc :: Eq c => c -> [c] -> [[c]] +splitc c s = case break (== c) s of + (i, _c:rest) -> i : splitc c rest + (i, []) -> i : [] + +-- | same as Data.List.Utils.replace +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old diff --git a/src/Utility/SystemDirectory.hs b/src/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module Utility.SystemDirectory ( module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/src/Utility/Tuple.hs b/src/Utility/Tuple.hs @@ -0,0 +1,17 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.Tuple where + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs @@ -15,6 +15,8 @@ module Utility.UserInfo ( ) where import Utility.Env +import Utility.Data +import Utility.Exception import System.PosixCompat import Control.Applicative @@ -24,7 +26,7 @@ import Prelude - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = myVal env homeDirectory +myHomeDir = either giveup return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] @@ -33,7 +35,7 @@ myHomeDir = myVal env homeDirectory #endif {- Current user's user name. -} -myUserName :: IO String +myUserName :: IO (Either String String) myUserName = myVal env userName where #ifndef mingw32_HOST_OS @@ -47,15 +49,15 @@ myUserGecos :: IO (Maybe String) #if defined(__ANDROID__) || defined(mingw32_HOST_OS) myUserGecos = return Nothing #else -myUserGecos = Just <$> myVal [] userGecos +myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif -myVal :: [String] -> (UserEntry -> String) -> IO String +myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars where #ifndef mingw32_HOST_OS - go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) + go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else - go [] = extract <$> error ("environment not set: " ++ show envvars) + go [] = return $ Left ("environment not set: " ++ show envvars) #endif - go (v:vs) = maybe (go vs) return =<< getEnv v + go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v diff --git a/src/propellor-config.hs b/src/propellor-config.hs @@ -0,0 +1 @@ +../config.hs+ \ No newline at end of file diff --git a/src/wrapper.hs b/src/wrapper.hs @@ -20,6 +20,7 @@ import Utility.Directory import Utility.FileMode import Utility.Process import Utility.Process.NonConcurrent +import Utility.FileSystemEncoding import System.Environment (getArgs) import System.Exit @@ -30,7 +31,9 @@ import Control.Applicative import Prelude main :: IO () -main = withConcurrentOutput $ go =<< getArgs +main = withConcurrentOutput $ do + useFileSystemEncoding + go =<< getArgs where go ["--init"] = interactiveInit go args = ifM configInCurrentWorkingDirectory diff --git a/stack.yaml b/stack.yaml @@ -1,4 +1,4 @@ # When updating the resolver here, also update stackResolver in Propellor.DotDir -resolver: lts-5.10 +resolver: lts-8.22 packages: - '.'