propellor

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

commit ff6173d6cd45e383da0f315bc80b52d486306cbc
Author: build <build@buildhost>
Date:   Tue, 22 Nov 2016 14:16:29 -0700

distributed version of propellor

Diffstat:
CHANGELOG | 2++
LICENSE | 22++++++++++++++++++++++
Makefile | 54++++++++++++++++++++++++++++++++++++++++++++++++++++++
README.md | 2++
Setup.hs | 5+++++
config-freebsd.hs | 66++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
config-simple.hs | 29+++++++++++++++++++++++++++++
config.hs | 2++
contrib/post-merge-hook | 44++++++++++++++++++++++++++++++++++++++++++++
debian/changelog | 1354+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
debian/compat | 1+
debian/control | 134+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
debian/copyright | 28++++++++++++++++++++++++++++
debian/lintian-overrides | 0
debian/propellor.README.Debian | 14++++++++++++++
debian/rules | 15+++++++++++++++
doc/README.mdwn | 56++++++++++++++++++++++++++++++++++++++++++++++++++++++++
joeyconfig.hs | 658+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
propellor.cabal | 232+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor.hs | 76++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Base.hs | 59+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Bootstrap.hs | 229+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/CmdLine.hs | 212+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Container.hs | 65+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Debug.hs | 37+++++++++++++++++++++++++++++++++++++
src/Propellor/DotDir.hs | 435+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Engine.hs | 96+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/EnsureProperty.hs | 73+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Exception.hs | 38++++++++++++++++++++++++++++++++++++++
src/Propellor/Git.hs | 41+++++++++++++++++++++++++++++++++++++++++
src/Propellor/Git/Config.hs | 49+++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Git/VerifiedBranch.hs | 52++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Gpg.hs | 206+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Info.hs | 183+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Location.hs | 5+++++
src/Propellor/Message.hs | 169+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/PrivData.hs | 296+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/PrivData/Paths.hs | 31+++++++++++++++++++++++++++++++
src/Propellor/PropAccum.hs | 89+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property.hs | 366+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Aiccu.hs | 54++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Apache.hs | 214+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Apt.hs | 353+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Apt/PPA.hs | 115+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Attic.hs | 149+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Borg.hs | 155+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Ccache.hs | 135+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Chroot.hs | 288+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Chroot/Util.hs | 33+++++++++++++++++++++++++++++++++
src/Propellor/Property/Cmd.hs | 98+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Concurrent.hs | 135+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Conductor.hs | 337+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/ConfFile.hs | 116+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Cron.hs | 86+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/DebianMirror.hs | 156+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Debootstrap.hs | 246+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/DiskImage.hs | 346+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/DiskImage/PartSpec.hs | 81+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Dns.hs | 550+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/DnsSec.hs | 122+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Docker.hs | 714+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Fail2Ban.hs | 30++++++++++++++++++++++++++++++
src/Propellor/Property/File.hs | 223+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Firejail.hs | 31+++++++++++++++++++++++++++++++
src/Propellor/Property/Firewall.hs | 205+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/FreeBSD.hs | 13+++++++++++++
src/Propellor/Property/FreeBSD/Pkg.hs | 88+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/FreeBSD/Poudriere.hs | 143+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Fstab.hs | 111+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Git.hs | 163+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Gpg.hs | 63+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Group.hs | 18++++++++++++++++++
src/Propellor/Property/Grub.hs | 87+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/HostingProvider/CloudAtCost.hs | 29+++++++++++++++++++++++++++++
src/Propellor/Property/HostingProvider/DigitalOcean.hs | 26++++++++++++++++++++++++++
src/Propellor/Property/HostingProvider/Exoscale.hs | 37+++++++++++++++++++++++++++++++++++++
src/Propellor/Property/HostingProvider/Linode.hs | 33+++++++++++++++++++++++++++++++++
src/Propellor/Property/Hostname.hs | 104+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Journald.hs | 55+++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Kerberos.hs | 95+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/LetsEncrypt.hs | 107+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/LightDM.hs | 16++++++++++++++++
src/Propellor/Property/List.hs | 59+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Locale.hs | 83+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Logcheck.hs | 36++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Mount.hs | 127+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Network.hs | 116+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Nginx.hs | 47+++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/OS.hs | 253+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Obnam.hs | 159+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/OpenId.hs | 50++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Parted.hs | 203+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Partition.hs | 91+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Postfix.hs | 321+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/PropellorRepo.hs | 19+++++++++++++++++++
src/Propellor/Property/Prosody.hs | 51+++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Reboot.hs | 137+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Rsync.hs | 62++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Sbuild.hs | 533+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Scheduled.hs | 70++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Schroot.hs | 63+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Service.hs | 27+++++++++++++++++++++++++++
src/Propellor/Property/SiteSpecific/Branchable.hs | 68++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 213+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/SiteSpecific/GitHome.hs | 36++++++++++++++++++++++++++++++++++++
src/Propellor/Property/SiteSpecific/JoeySites.hs | 927+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Ssh.hs | 433+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Sudo.hs | 33+++++++++++++++++++++++++++++++++
src/Propellor/Property/Systemd.hs | 473+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Systemd/Core.hs | 10++++++++++
src/Propellor/Property/Tor.hs | 199+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Unbound.hs | 142+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/User.hs | 205+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Uwsgi.hs | 49+++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/ZFS.hs | 11+++++++++++
src/Propellor/Property/ZFS/Process.hs | 32++++++++++++++++++++++++++++++++
src/Propellor/Property/ZFS/Properties.hs | 40++++++++++++++++++++++++++++++++++++++++
src/Propellor/Protocol.hs | 72++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Shim.hs | 84+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Spin.hs | 390+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Ssh.hs | 79+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types.hs | 197+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Chroot.hs | 47+++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/CmdLine.hs | 31+++++++++++++++++++++++++++++++
src/Propellor/Types/Container.hs | 30++++++++++++++++++++++++++++++
src/Propellor/Types/Core.hs | 106+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Dns.hs | 177+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Docker.hs | 37+++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Empty.hs | 16++++++++++++++++
src/Propellor/Types/Exception.hs | 22++++++++++++++++++++++
src/Propellor/Types/Info.hs | 92+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/MetaTypes.hs | 213+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/OS.hs | 149+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/PrivData.hs | 134+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Result.hs | 38++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/ResultCheck.hs | 85+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/Singletons.hs | 49+++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Types/ZFS.hs | 134+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Utilities.hs | 27+++++++++++++++++++++++++++
src/System/Console/Concurrent.hs | 44++++++++++++++++++++++++++++++++++++++++++++
src/System/Console/Concurrent/Internal.hs | 546+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/System/Process/Concurrent.hs | 34++++++++++++++++++++++++++++++++++
src/Utility/Applicative.hs | 16++++++++++++++++
src/Utility/Data.hs | 19+++++++++++++++++++
src/Utility/DataUnits.hs | 162+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Directory.hs | 247+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Env.hs | 84+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Exception.hs | 109+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/FileMode.hs | 168+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/FileSystemEncoding.hs | 174+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/HumanNumber.hs | 21+++++++++++++++++++++
src/Utility/LinuxMkLibs.hs | 62++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Misc.hs | 150+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Monad.hs | 71+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/PartialPrelude.hs | 70++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Path.hs | 328+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/PosixFiles.hs | 42++++++++++++++++++++++++++++++++++++++++++
src/Utility/Process.hs | 399+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Process/NonConcurrent.hs | 35+++++++++++++++++++++++++++++++++++
src/Utility/Process/Shim.hs | 4++++
src/Utility/SafeCommand.hs | 136+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Scheduled.hs | 361+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/SystemDirectory.hs | 16++++++++++++++++
src/Utility/Table.hs | 29+++++++++++++++++++++++++++++
src/Utility/ThreadScheduler.hs | 74++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/Tmp.hs | 124+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Utility/UserInfo.hs | 61+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/config.hs | 2++
src/wrapper.hs | 81+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
stack.yaml | 4++++
170 files changed, 22945 insertions(+), 0 deletions(-)

diff --git a/CHANGELOG b/CHANGELOG @@ -0,0 +1 @@ +debian/changelog+ \ No newline at end of file diff --git a/LICENSE b/LICENSE @@ -0,0 +1,22 @@ +Copyright 2014 Joey Hess <id@joeyh.name> and contributors. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Makefile b/Makefile @@ -0,0 +1,54 @@ +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 + +install: + install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor + install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor + mkdir -p dist/gittmp + $(CABAL) sdist + cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1) + # cabal sdist does not preserve symlinks, so copy over file + cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done + # reset mtime on files in git bundle so bundle is reproducible + find dist/gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)" + export GIT_AUTHOR_NAME=build \ + && export GIT_AUTHOR_EMAIL=build@buildhost \ + && export GIT_AUTHOR_DATE="$(DATE)" \ + && export GIT_COMMITTER_NAME=build \ + && export GIT_COMMITTER_EMAIL=build@buildhost \ + && export GIT_COMMITTER_DATE="$(DATE)" \ + && cd dist/gittmp && git init \ + && git add . \ + && git commit -q -m "distributed version of propellor" \ + && git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \ + && git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head + rm -rf dist/gittmp + +clean: + rm -rf dist Setup tags propellor propellor.1 privdata/local + find -name \*.o -exec rm {} \; + find -name \*.hi -exec rm {} \; + +# hothasktags chokes on some template haskell etc, so ignore errors +# duplicate tags with Propellor.Property. removed from the start, as we +# often import qualified by just the module base name. +tags: + find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true + +dist/setup-config: propellor.cabal + @if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi + @$(CABAL) configure + +propellor.1: doc/usage.mdwn doc/mdwn2man + doc/mdwn2man propellor 1 < doc/usage.mdwn > propellor.1 + +.PHONY: tags diff --git a/README.md b/README.md @@ -0,0 +1 @@ +doc/README.mdwn+ \ No newline at end of file diff --git a/Setup.hs b/Setup.hs @@ -0,0 +1,5 @@ +{- cabal setup file -} + +import Distribution.Simple + +main = defaultMain diff --git a/config-freebsd.hs b/config-freebsd.hs @@ -0,0 +1,66 @@ +-- This is the main configuration file for Propellor, and is used to build +-- the propellor program. +-- +-- This shows how to set up a FreeBSD host (and a Linux host too). + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Network as Network +import qualified Propellor.Property.Cron as Cron +import Propellor.Property.Scheduled +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Docker as Docker +import qualified Propellor.Property.FreeBSD.Pkg as Pkg +import qualified Propellor.Property.ZFS as ZFS +import qualified Propellor.Property.FreeBSD.Poudriere as Poudriere + +main :: IO () +main = defaultMain hosts + +-- The hosts propellor knows about. +hosts :: [Host] +hosts = + [ freebsdbox + , linuxbox + ] + +-- An example freebsd host. +freebsdbox :: Host +freebsdbox = host "freebsdbox.example.com" $ props + & osFreeBSD (FBSDProduction FBSD102) X86_64 + & Pkg.update + & Pkg.upgrade + & Poudriere.poudriere poudriereZFS + & Poudriere.jail (Poudriere.Jail "formail" (fromString "10.2-RELEASE") (fromArchitecture X86_64)) + +poudriereZFS :: Poudriere.Poudriere +poudriereZFS = Poudriere.defaultConfig + { Poudriere._zfs = Just $ Poudriere.PoudriereZFS + (ZFS.ZFS (fromString "zroot") (fromString "poudriere")) + (ZFS.fromList [ZFS.Mountpoint (fromString "/poudriere"), ZFS.ACLInherit ZFS.AIPassthrough]) + } + +-- An example linux host. +linuxbox :: Host +linuxbox = host "linuxbox.example.com" $ props + & osDebian' KFreeBSD Unstable X86_64 + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & Apt.installed ["etckeeper"] + & Apt.installed ["ssh"] + & User.hasSomePassword (User "root") + & Network.ipv6to4 + & File.dirExists "/var/www" + & Docker.docked webserverContainer + & Docker.garbageCollected `period` Daily + & Cron.runPropellor (Cron.Times "30 * * * *") + +-- A generic webserver in a Docker container. +webserverContainer :: Docker.Container +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props + & osDebian' KFreeBSD (Stable "jessie") X86_64 + & Apt.stdSourcesList + & Docker.publish "80:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" diff --git a/config-simple.hs b/config-simple.hs @@ -0,0 +1,29 @@ +-- This is the main configuration file for Propellor, and is used to build +-- the propellor program. + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.User as User + +main :: IO () +main = defaultMain hosts + +-- The hosts propellor knows about. +hosts :: [Host] +hosts = + [ mybox + ] + +-- An example host. +mybox :: Host +mybox = host "mybox.example.com" $ props + & osDebian Unstable X86_64 + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & Apt.installed ["etckeeper"] + & Apt.installed ["ssh"] + & User.hasSomePassword (User "root") + & File.dirExists "/var/www" + & Cron.runPropellor (Cron.Times "30 * * * *") diff --git a/config.hs b/config.hs @@ -0,0 +1 @@ +config-simple.hs+ \ No newline at end of file diff --git a/contrib/post-merge-hook b/contrib/post-merge-hook @@ -0,0 +1,44 @@ +#!/bin/sh +# +# git post-merge hook, used by propellor's author to maintain a +# joeyconfig branch with some changes while being able to merge +# between it and branches without the changes. +# +# Each time this hook is run, it checks if it's on a branch with +# name ending in "config". If so, config.hs is pointed at $branch.hs +# and privdata/relocate is written to make files in privdata/.$branch/ be +# used. +# +# Otherwise, config.hs is pointed at config-simple.hs, and +# privdata/relocate is removed. + +set -e + +commit () { + if [ -n "$(git status --short privdata/relocate config.hs)" ]; then + git commit privdata/relocate config.hs -m "$1" + fi +} + +branch="$(git symbolic-ref --short HEAD)" +case "$branch" in + "") + true + ;; + *config) + ln -sf "$branch".hs config.hs + git add config.hs + echo ".$branch" > privdata/relocate + git add privdata/relocate + commit "setting up $branch after merge" + ;; + *) + ln -sf config-simple.hs config.hs + git add config.hs + if [ -e privdata/relocate ]; then + rm -f privdata/relocate + git rm --quiet privdata/relocate + fi + commit "clean up after merge" + ;; +esac diff --git a/debian/changelog b/debian/changelog @@ -0,0 +1,1354 @@ +propellor (3.2.3-1+b1) sid; urgency=low, binary-only=yes + + * Binary-only non-maintainer upload for amd64; no source changes. + * rebuild with PIE + + -- amd64 Build Daemon (binet) <buildd-binet@buildd.debian.org> Tue, 22 Nov 2016 14:16:29 -0700 + +propellor (3.2.3-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Tue, 22 Nov 2016 14:16:29 -0700 + +propellor (3.2.3) unstable; urgency=medium + + * Improve extraction of gpg secret key id list, to work with gpg 2.1. + * The propellor wrapper checks if ./config.hs exists; if so it runs + using the configuration in the current directory, rather than + ~/.propellor/config.hs + * Debootstap: Fix too tight permissions lock down of debootstrapped + chroots, which prevented non-root users from doing anything in the + chroot. + + -- Joey Hess <id@joeyh.name> Tue, 22 Nov 2016 11:36:18 -0400 + +propellor (3.2.2-1) unstable; urgency=medium + + * Package new upstream release. + * Add two overrides for spelling-error-in-binary in libghc-propellor-dev. + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 13 Nov 2016 20:47:44 -0700 + +propellor (3.2.2) unstable; urgency=medium + + * Added Linode.serialGrub property. + * Clean up build warnings about redundant constraints when built with ghc 8.0. + * Added Group.hasUser property. Thanks, Daniel Brooks + + -- Joey Hess <id@joeyh.name> Fri, 11 Nov 2016 17:54:44 -0400 + +propellor (3.2.1-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 08 Oct 2016 08:52:57 -0700 + +propellor (3.2.1) unstable; urgency=medium + + * Simplify Debootstrap.sourceInstall since #770217 was fixed. + * Debootstap.installed: Fix inverted logic that made this never install + debootstrap. Thanks, mithrandi. + + -- Joey Hess <id@joeyh.name> Mon, 03 Oct 2016 18:06:31 -0400 + +propellor (3.2.0-1) unstable; urgency=medium + + * Package new upstream release. + * Drop no-upstream-changelog libghc-propellor-doc Lintian override. + Obsoleted by new haskell-devscripts. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 10 Sep 2016 18:55:56 -0700 + +propellor (3.2.0) unstable; urgency=medium + + [ Sean Whitton ] + * Using ccache with Sbuild.built & Sbuild.builtFor is now toggleable: these + properties now take a parameter of type Sbuild.UseCcache. (API Change) + * Sbuild.piupartsConf: no longer takes an Apt.Url. (API Change) + * Sbuild.piupartsConf & Sbuild.piupartsConfFor: does nothing if corresponding + schroot not built. + Previously, these properties built the schroot if it was missing. + * Sbuild.built & Sbuild.piupartsConf: add an additional alias to sid chroots. + This is for compatibility with `dgit sbuild`. + * Further improvements to Sbuild.hs haddock. + + [ Joey Hess ] + * Tor.hiddenService: Converted port parameter from Int to Port. (API change) + * Tor.hiddenServiceAvailable: The hidden service hostname file may not + be available immedaitely after configuring tor; avoid ugly error in + this case. + + -- Joey Hess <id@joeyh.name> Sat, 10 Sep 2016 11:39:40 -0400 + +propellor (3.1.2-2) unstable; urgency=medium + + * Re-upload including orig.tar + * Update README.source about -v_ + + -- Sean Whitton <spwhitton@spwhitton.name> Mon, 05 Sep 2016 17:10:44 -0700 + +propellor (3.1.2-1) unstable; urgency=medium + + * Package new upstream release. + * Drop patches obsoleted by upstream changes: + - 0001-remove-README.Debian-from-propellor.cabal.patch + - 0003-fix-ccache-haddock.patch + - 0004-pass-allow-unrelated-histories-to-git-merge.patch. + * Drop some unused lintian overrides. + * Override binary-or-shlib-defines-rpath for -dev package. + Standard libghc override. + + -- Sean Whitton <spwhitton@spwhitton.name> Mon, 05 Sep 2016 10:24:17 -0700 + +propellor (3.1.2) unstable; urgency=medium + + [ Joey Hess ] + * Ssh.knownHost: Bug fix: Only fix up the owner of the known_hosts + file after it exists. + + [ Sean Whitton ] + * Sbuild.keypairInsecurelyGenerated: Improved to be more robust. + * Pass --allow-unrelated-histories to git merge when run with git 2.9 or + newer. This fixes the /usr/bin/propellor wrapper with this version of git. + * Sbuild.built & Sbuild.builtFor no longer require Sbuild.keypairGenerated. + Transition guide: If you are using sbuild 0.70.0 or newer, you should + `rm -r /var/lib/sbuild/apt-keys`. Otherwise, you should add either + Sbuild.keypairGenerated or Sbuild.keypairInsecurelyGenerated to your host. + * Sbuild haddock improvements: + - State that we don't support squeeze and Buntish older than trusty. + This is due to our enhancements, such as eatmydata. + - State that you need sbuild 0.70.0 or newer to build for stretch. + This is due to gpg2 hitting Debian stretch. + - Explain when a keygen is required. + - Update sample ~/.sbuildrc for sbuild 0.71.0. + - Add hint for customising chroots with propellor. + - Update example usage of System type. + + -- Joey Hess <id@joeyh.name> Sun, 28 Aug 2016 14:39:23 -0400 + +propellor (3.1.1) unstable; urgency=medium + + * Haddock build fix. + Thanks, Sean Whitton + + -- Joey Hess <id@joeyh.name> Thu, 23 Jun 2016 08:12:57 -0400 + +propellor (3.1.0-2) unstable; urgency=medium + + * Add 0004-pass-allow-unrelated-histories-to-git-merge.patch (Closes: #834895) + Thanks to Fred Picca for reporting the problem. + - Tighten dependency on git to >= 1:2.9 for --allow-unrelated-histories + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 20 Aug 2016 08:20:17 -0700 + +propellor (3.1.0-1) unstable; urgency=medium + + * Package new upstream release. + * Add 0002-dpkg-mergechangelogs.patch to facilitate uploading with dgit. + Adding this patch ensures that HEAD matches the unpacked source package. + * Add README.source. + * Add 0003-fix-ccache-haddock.patch. + + -- Sean Whitton <spwhitton@spwhitton.name> Thu, 23 Jun 2016 18:31:41 +0900 + +propellor (3.1.0) unstable; urgency=medium + + * Architecture changed from String to an ADT. (API Change) + Transition guide: Change "amd64" to X86_64, "i386" to X86_32, + "armel" to ARMEL, etc. + Thanks, Félix Sipma. + * The Debian data type now includes a DebianKernel. (API Change) + This won't affect most config.hs, as osDebian defaults to + Linux. Added osDebian' can be used to specify a different kernel. + Thanks, Félix Sipma. + * Improve exception handling. A property that threw a non-IOException + used to stop the whole propellor run. Now, all non-async exceptions + only make the property that threw them fail. (Implicit API change) + * Added StopPropellorException and stopPropellorMessage which can be + used in the unusual case where a failure of one property should stop + propellor from trying to ensure any other properties. + * tryPropellor returns Either SomeException instead of Either IOException + (API change) + * Switch letsencrypt to certbot package name. + * Sbuild: Add keyringInsecurelyGenerated which is useful on throwaway + build VMs. + Thanks, Sean Whitton + * Added Propellor.Property.SiteSpecific.Exoscale. + Thanks, Sean Whitton + * Property.Reboot: Added toDistroKernel and toKernelNewerThan. + Thanks, Sean Whitton + * Added ConfFile.hasIniSection. + Thanks, Félix Sipma. + * Apt.install: When asked to install a package that apt does not know + about, it used to incorrectly succeed. Now it will fail. + * Property.Firejail: New module. + Thanks, Sean Whitton + * File: Write privdata files in binary rather than text, which avoids + failure when they do not contain valid unicode. + Thanks, Andrew Schurman + * Generalized fileProperty can now operate on a file as either a series + of lines, or a ByteString. + + [ Sean Whitton ] + * New info property Schroot.useOverlays to indicate whether you want schroots + set up by propellor to use the Linux kernel's OverlayFS. + * Schroot.overlaysInTmpfs sets Schroot.useOverlays info property. + * If you have indicated that you want schroots to use OverlayFS and the + current kernel does not support it, Sbuild.built will attempt to reboot + into a kernel that does, or fail if it can't find one. + * Sbuild.built will no longer add duplicate `aliases=UNRELEASED,sid...` lines + to more than one schroot config. It will not remove any such lines that the + previous version of propellor added, though. + * Sbuild.keypairGenerated works around Debian bug #792100 by creating the + directory /root/.gnupg in advance. + * Ccache.hasCache now sets the setgid bit on the cache directory, as + ccache requires. + + -- Joey Hess <id@joeyh.name> Wed, 22 Jun 2016 15:29:27 -0400 + +propellor (3.0.5-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Fri, 10 Jun 2016 15:21:47 +0900 + +propellor (3.0.5) unstable; urgency=medium + + * Modules added for Sbuild and Ccache. + Thanks, Sean Whitton + * Systemd: Added killUserProcesses property, which can be reverted + to return systemd to its default behavior before version 230 started + killing processes like screen sessions. + * Systemd: Added logindConfigured property. + + -- Joey Hess <id@joeyh.name> Mon, 06 Jun 2016 17:13:21 -0400 + +propellor (3.0.4-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Tue, 24 May 2016 15:34:24 +0900 + +propellor (3.0.4) unstable; urgency=medium + + * Run letsencrypt with --noninteractive. + * Fix build with ghc 8.0.1. + Thanks, davean. + * Module added for the Borg backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess <id@joeyh.name> Sun, 22 May 2016 15:54:49 -0400 + +propellor (3.0.3-2) unstable; urgency=medium + + * Use CDBS & haskell-devscripts to build new binary packages + libghc-propellor-{dev,prof,doc}. + * Add X-Description: field to debian/control. + * Add patch removing README.Debian from propellor.cabal. + * Re-arrange files in debian/ to deal with multiple binary packages. + - Use debian/propellor.manpages and debian/propellor.docs instead of + overrides in debian/rules. + - Add Lintian overrides duplicate-{short,long}-description. + - Rename README.Debian, lintian-overrides to correspond to particular + binary packages. + - Add libghc-propellor-{dev,prof,doc}.links duplicating propellor.links. + * Binary package propellor now depends on libghc-propellor-dev. + This fixes using propellor as a library, as set up by propellor --init + option B. Closes: + https://propellor.branchable.com/todo/propellor_--init_option_B_failure/ + * Update Source: field and copyright year in debian/copyright. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 07 May 2016 10:59:53 -0700 + +propellor (3.0.3-1) unstable; urgency=medium + + * Package new upstream release. + * Bump standards version to 3.9.8 (no changes required). + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 01 May 2016 17:12:29 -0700 + +propellor (3.0.3) unstable; urgency=medium + + * Remove Propellor.DotDir from the propellor library, as its use of + Paths_propellor prevents use of the module out of propellor's tree. + This module is only needed for the wrapper program anyway, which + handles --init. + + -- Joey Hess <id@joeyh.name> Sun, 01 May 2016 17:51:37 -0400 + +propellor (3.0.2) unstable; urgency=medium + + * Added Apt.periodicUpdates. + Thanks, Félix Sipma. + * Apt.unattendedUpgrades: Enable mailing problem reports to root. + Thanks, Félix Sipma. + * Added Propellor.Property.Fstab, and moved the fstabbed property to there. + * Attic module added for the backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess <id@joeyh.name> Sat, 30 Apr 2016 15:46:50 -0400 + +propellor (3.0.1-1) unstable; urgency=medium + + * Package new upstream release. + * Remove obsolete debian/NEWS to minimise confusion. + + -- Sean Whitton <spwhitton@spwhitton.name> Wed, 06 Apr 2016 07:20:20 -0700 + +propellor (3.0.1) unstable; urgency=medium + + * propellor --init now runs cabal sandbox init if cabal has been + configured with require-sandbox: True. + Thanks, Sean Whitton + * Re-bundled concurrent-output so propellor can be deployed to Debian + stable systems without installing it (insecurely) from hackage. + + -- Joey Hess <id@joeyh.name> Tue, 05 Apr 2016 13:35:54 -0400 + +propellor (3.0.0-1) unstable; urgency=medium + + * New upstream version. + * Create debian/NEWS to detail a caveat when upgrading to this new version. + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 03 Apr 2016 11:35:35 -0700 + +propellor (3.0.0) unstable; urgency=medium + + * Property types have been improved to indicate what systems they target. + This prevents using eg, Property FreeBSD on a Debian system. + Transition guide for this sweeping API change: + - First, upgrade to propellor 2.17.2 and deploy that to all your hosts. + Otherwise, propellor --spin will fail when you upgrade to + propellor 3.0.0. + - Change "host name & foo & bar" + to "host name $ props & foo & bar" + - Similarly, `propertyList` and `combineProperties` need `props` + to be used to combine together properties; they no longer accept + lists of properties. (If you have such a list, use `toProps`.) + - And similarly, Chroot, Docker, and Systemd container need `props` + to be used to combine together the properies used inside them. + - The `os` property is removed. Instead use `osDebian`, `osBuntish`, + or `osFreeBSD`. These tell the type checker the target OS of a host. + - Change "Property NoInfo" to "Property UnixLike" + - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" + - Change "RevertableProperty NoInfo" to + "RevertableProperty UnixLike UnixLike" + - Change "RevertableProperty HasInfo" to + "RevertableProperty (HasInfo + UnixLike) UnixLike" + - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. + This is enabled by default for all modules in propellor.cabal. But + if you are using propellor as a library, you may need to enable it + manually. + - If you know a property only works on a particular OS, like Debian + or FreeBSD, use that instead of "UnixLike". For example: + "Property Debian" + - It's also possible make a property support a set of OS's, for example: + "Property (Debian + FreeBSD)" + - Removed `infoProperty` and `simpleProperty` constructors, instead use + `property` to construct a Property. + - Due to the polymorphic type returned by `property`, additional type + signatures tend to be needed when using it. For example, this will + fail to type check, because the type checker cannot guess what type + you intend the intermediate property "go" to have: + foo :: Property UnixLike + foo = go `requires` bar + where + go = property "foo" (return NoChange) + To fix, specify the type of go: + go :: Property UnixLike + - `ensureProperty` now needs to be passed a witness to the type of the + property it's used in. + change this: foo = property desc $ ... ensureProperty bar + to this: foo = property' desc $ \w -> ... ensureProperty w bar + - General purpose properties like cmdProperty have type "Property UnixLike". + When using that to run a command only available on Debian, you can + tighten the type to only the OS that your more specific property works on. + For example: + upgraded :: Property Debian + upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) + - Several utility functions have been renamed: + getInfo to fromInfo + propertyInfo to getInfo + propertyDesc to getDesc + propertyChildren to getChildren + * The new `pickOS` property combinator can be used to combine different + properties, supporting different OS's, into one Property that chooses + which to use based on the Host's OS. + * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling + these complex new types. + * Added dependency on concurrent-output; removed embedded copy. + * Apt.PPA: New module, contributed by Evan Cofsky. + * Improved propellor's first run experience; propellor --init will + walk the user through setting up ~/.propellor, with a choice between + 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. + * When propellor is installed using stack, propellor --init will + automatically set propellor.buildsystem=stack. + + -- Joey Hess <id@joeyh.name> Sat, 02 Apr 2016 15:33:26 -0400 + +propellor (2.17.2-1) unstable; urgency=low + + * New upstream version. + + -- Sean Whitton <spwhitton@spwhitton.name> Thu, 31 Mar 2016 17:26:19 -0700 + +propellor (2.17.2) unstable; urgency=medium + + * When new dependencies are added to propellor or the propellor config, + try harder to get them installed. In particular, this makes + propellor --spin work when the remote host needs to get dependencies + installed in order to build the updated config. + * Apt.update: Also run dpkg --configure -a here as apt for some reason + won't even update if dpkg was interrupted. + + -- Joey Hess <id@joeyh.name> Wed, 30 Mar 2016 15:45:08 -0400 + +propellor (2.17.1-1) unstable; urgency=medium + + * New upstream version. + + -- Sean Whitton <spwhitton@spwhitton.name> Tue, 29 Mar 2016 08:30:00 -0700 + +propellor (2.17.1) unstable; urgency=medium + + * Avoid generating excessively long paths to the unix socket file + used for ssh connection caching. Mostly. Can still generate a too long + one if $HOME is longer than 60 bytes. + * Uwsgi: add ".ini" extension to app config files. + Files without extensions were ignored by uwsgi. + Thanks, Félix Sipma. + + -- Joey Hess <id@joeyh.name> Mon, 28 Mar 2016 11:06:34 -0400 + +propellor (2.17.0) unstable; urgency=medium + + * Added initial support for FreeBSD. + Thanks, Evan Cofsky. + * Added Propellor.Property.ZFS. + Thanks, Evan Cofsky. + * Firewall: Reorganized Chain data type. (API change) + Thanks, Félix Sipma. + * Firewall: Separated Table and Target (API change) + Thanks, Félix Sipma. + * Ssh: change type of listenPort from Int to Port (API change) + Thanks, Félix Sipma. + * Firewall: add TCPFlag, Frequency, TCPSyn, ICMPTypeMatch, NatDestination + Thanks, Félix Sipma. + * Network: Filter out characters not allowed in interfaces.d files. + Thanks, Félix Sipma. + * Apt.upgrade: Run dpkg --configure -a first, to recover from + interrupted upgrades. + * Apt: Add safeupgrade. + * Force ssh, scp, and git commands to be run in the foreground. + Should fix intermittent hangs of propellor --spin. + * Avoid repeated re-building on systems such as FreeBSD where building + re-links the binary even when there are no changes. + * Locale.available: Run locale-gen, instead of dpkg-reconfigure locales, + which modified the locale.gen file and sometimes caused the property to + need to make changes every time. + * Speed up propellor's build of itself, by asking cabal to only build + the propellor-config binary and not all the libraries. + * Tor.named: Fix bug that sometimes caused the property to fail the first + time, though retrying succeeded. + + -- Joey Hess <id@joeyh.name> Thu, 24 Mar 2016 14:53:31 -0400 + +propellor (2.16.0-1) unstable; urgency=medium + + * New upstream version. + * Create changelog symlink with dh_link instead of in debian/rules. + In accordance with policy 12.3: a package cannot assume the existence of + /usr/share/doc. + * Bump standards version to 3.9.7 (no changes required). + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 28 Feb 2016 17:02:24 -0700 + +propellor (2.16.0) unstable; urgency=medium + + * Obnam: Only let one backup job run at a time when a host has multiple + different backup properties, to avoid concurrent jobs fighting over + scarce resources (particularly memory). Other jobs block on a lock + file. + * Removed references to a Debian derivative from code and documentation + because of an unfortunate trademark use policy. + http://joeyh.name/blog/entry/trademark_nonsense/ + * That included changing a data constructor to "Buntish", an API change. + * Firewall.rule: Now takes a Table parameter. (API change) + * Firewall: add InIFace/OutIFace Rules, add Source/Destination Rules, + add CustomTarget, and more improvements. + Thanks, Félix Sipma. + * Ssh.authorizedKey: Fix bug preventing it from working when the + authorized_keys file does not yet exist. + * Removed Ssh.unauthorizedKey and made Ssh.authorizedKey revertable. + (API change) + + -- Joey Hess <id@joeyh.name> Sat, 27 Feb 2016 13:31:57 -0400 + +propellor (2.15.4-1) unstable; urgency=medium + + * New upstream version. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 13 Feb 2016 11:52:53 -0700 + +propellor (2.15.4) unstable; urgency=medium + + * Build /usr/src/propellor/propellor.git reproducibly, + which makes the whole Debian package build reproducibly. + Thanks, Sean Whitton. + * Obnam: To cause old generations to be forgotten, keepParam can be + passed to a backup property; this causes obnam forget to be run. + * Delete /etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist when + unattended-upgrades is installed, to work around #812380 which results + in many warnings from apt, including in cron mails. + * Added Propellor.Property.LetsEncrypt + * Apache.httpsVirtualHost: New property, setting up a https vhost + with the certificate automatically obtained using letsencrypt. + * Allow using combineProperties and propertyList with lists of + RevertableProperty. + + -- Joey Hess <id@joeyh.name> Thu, 11 Feb 2016 12:49:10 -0400 + +propellor (2.15.3-1) unstable; urgency=medium + + * New upstream version. + * Fix override of Lintian tag debian-watch-may-check-gpg-signature. + + -- Sean Whitton <spwhitton@spwhitton.name> Tue, 12 Jan 2016 19:41:07 -0700 + +propellor (2.15.3) unstable; urgency=medium + + * Added Git.bareRepoDefaultBranch property + Thanks, Sean Whitton. + * Add missing Control.Applicative imports needed by older versions of ghc. + + -- Joey Hess <id@joeyh.name> Tue, 12 Jan 2016 12:37:22 -0400 + +propellor (2.15.2-1) unstable; urgency=medium + + * New upstream version. + * Fix duplicate Section: in debian/control file. + + -- Sean Whitton <spwhitton@spwhitton.name> Mon, 04 Jan 2016 12:14:47 +0000 + +propellor (2.15.2) unstable; urgency=medium + + * Added GNUPGBIN environment variable or git.program git config + to control the command run for gpg. Allows eg, GNUPGBIN=gpg2 + Thanks, Félix Sipma. + * Bootstrap apt-get installs run with deconf noninteractive frontend. + * spin --via: Avoid committing on relay host. + * Postfix: Add service property to enable/disable services in master.cf. + * Added Munin module, contributed by Jelmer Vernooij. + + -- Joey Hess <id@joeyh.name> Sun, 03 Jan 2016 16:56:26 -0400 + +propellor (2.15.1-1) unstable; urgency=medium + + * New upstream version. + * Add watch file. + * Fix specification of packaging branch in Vcs-Git: variable. + * Silence xargs during package build when hothasktags is not installed. + Patch accepted upstream for next upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 03 Jan 2016 17:05:27 +0000 + +propellor (2.15.1) unstable; urgency=medium + + * Added git configs propellor.spin-branch and propellor.forbid-dirty-spin. + Thanks, Sean Whitton. + * Added User.systemAccountFor and User.systemAccountFor' properties. + Thanks, Félix Sipma. + * Gpg.keyImported converted to not use a flag file and instead check + if gpg has the provided key already. + Thanks, Félix Sipma. + * Clean build with ghc 7.10. + * Merged Utility changes from git-annex. + + -- Joey Hess <id@joeyh.name> Sat, 19 Dec 2015 16:43:09 -0400 + +propellor (2.15.0-1) unstable; urgency=medium + + * Adopt propellor package (Closes: #768634). + * Switch dpkg-source format to 3.0 (quilt). + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 13 Dec 2015 11:33:02 -0700 + +propellor (2.15.0) unstable; urgency=medium + + * Added UncheckedProperty type, along with unchecked to indicate a + Property needs its result checked, and checkResult and changesFile + to check for changes. + * Properties that run an arbitrary command, such as cmdProperty + and scriptProperty are converted to use UncheckedProperty, since + they cannot tell on their own if the command truely made a change or not. + (API Change) + Transition guide: + - When GHC complains about an UncheckedProperty, add: + `assume` MadeChange + (Since these properties used to always return MadeChange, that + change is always safe to make.) + - Or, if you know that the command should modifiy a file, use: + `changesFile` filename + * The `trivial` combinator has been removed. (API change) + Instead, use: + `assume` NoChange + Or, better, use changesFile or checkResult to accurately report + when a property makes a change. + * A few properties have had their Result improved, for example + Apt.buldDep and Apt.autoRemove now check if a change was made or not. + * User.hasDesktopGroups changed to avoid trying to add the user to + groups that don't exist. + * Added Postfix.saslPasswdSet. + * Added Propellor.Property.Locale. + Thanks, Sean Whitton. + * Added Propellor.Property.Fail2Ban. + + -- Joey Hess <id@joeyh.name> Sun, 06 Dec 2015 15:33:51 -0400 + +propellor (2.14.0) unstable; urgency=medium + + * Add Propellor.Property.PropellorRepo.hasOriginUrl, an explicit way to + set the git repository url normally implicitly set when using --spin. + * Added Chroot.noServices property. + * DiskImage creation automatically uses Chroot.noServices. + * Removed the (unused) dependency on quickcheck. + * DebianMirror: Added a DebianMirror type for configuration (API change) + Thanks, Félix Sipma. + * DebianMirror: Add RsyncExtra to configuration. + Thanks, Félix Sipma. + * Added Git.repoConfigured and Git.repoAcceptsNonFFs properties. + Thanks, Sean Whitton + * Added User.hasDesktopGroups property. + + -- Joey Hess <id@joeyh.name> Tue, 24 Nov 2015 16:03:55 -0400 + +propellor (2.13.0) unstable; urgency=medium + + * RevertableProperty used to be assumed to contain info, but this is + now made explicit, with RevertableProperty HasInfo or + RevertableProperty NoInfo. (API change) + Transition guide: + - If you define a RevertableProperty, expect some type check + failures like: "Expecting one more argument to ‘RevertableProperty’". + - Change it to "RevertableProperty NoInfo" + - The compiler will then tell you if it needs "HasInfo" instead. + - If you have code that uses the RevertableProperty constructor + that fails to type check, use the more powerful <!> operator + instead to create the RevertableProperty. + * Various property combinators that combined a RevertableProperty + with a non-revertable property used to yield a RevertableProperty. + This was a bug, because the combined property could not be fully + reverted in many cases, and the result is now a non-revertable property. + * combineWith now takes an additional parameter to control how revert + actions are combined (API change). + * Added Propellor.Property.Concurrent for concurrent properties. + * Made the execProcess exported by propellor, and everything built on it, + avoid scrambled output when run concurrently. + * Propellor now depends on STM and text. + * The cabal file now builds propellor with -O. While -O0 makes ghc + take less memory while building propellor, it can lead to bad memory + usage at runtime due to eg, disabled stream fusion. + * Add File.isCopyOf. Thanks, Per Olofsson. + + -- Joey Hess <id@joeyh.name> Sun, 08 Nov 2015 14:51:15 -0400 + +propellor (2.12.0) unstable; urgency=medium + + * The DiskImage module can now make bootable images using grub. + * Add a ChrootTarball chroot type, for using pre-built tarballs + as chroots. Thanks, Ben Boeckel. + * HostName: Improve domain extraction code. + * Added Mount.fstabbed property to generate /etc/fstab to replicate + current mounts. + * HostName: Improve domain extraction code. + * Add File.basedOn. Thanks, Per Olofsson. + * Changed how the operating system is provided to Chroot (API change). + Where before debootstrapped and bootstrapped took a System parameter, + the os property should now be added to the Chroot. + * Follow-on change to Systemd.container, which now takes a System parameter. + * Generalized Property.check so it can be used with Propellor actions as + well as IO actions. + * Hostname.sane and Hostname.setTo can now safely be used as a property + of a chroot, and won't affect the hostname of the host system. + + -- Joey Hess <id@joeyh.name> Fri, 23 Oct 2015 17:38:32 -0400 + +propellor (2.11.0) unstable; urgency=medium + + * Rewrote Propellor.Property.ControlHeir one more time, renaming it to + Propellor.Property.Conductor. + * Added Ssh properties to remove authorized_keys and known_hosts lines. + + -- Joey Hess <id@joeyh.name> Wed, 21 Oct 2015 19:49:00 -0400 + +propellor (2.10.0) unstable; urgency=medium + + * The Propellor.Property.Spin added in the last release is replaced + with a very different Propellor.Property.ControlHeir. + + -- Joey Hess <id@joeyh.name> Tue, 20 Oct 2015 21:29:12 -0400 + +propellor (2.9.0) unstable; urgency=medium + + * Added basic Uwsgi module, maintained by Félix Sipma. + * Add Apt.hasForeignArch. Thanks, Per Olofsson. + * Improved documentation, particularly of the Propellor module. + * The Propellor module no longer exports many of the things it used to, + being now focused on only what's needed to write config.hs. + Use Propellor.Base to get all the things exported by Propellor before. + (API change) + * Some renaming of instance methods, and moving of functions to more + appropriate modules. (API change) + * Added File.isSymlinkedTo. Thanks, Per Olofsson. + * fileProperty, and properties derived from it now write the new + file content via origfile.propellor-new~, instead of to a randomly named + temp file. This allows them to clean up any temp file that may have + been left by an interrupted run of propellor. + * Added Propellor.Property.Spin, which can be used to make a host be a + controller of other hosts, which will automatically spin them each time + propellor is run. + * Ssh.keyImported is replaced with Ssh.userKeys. (API change) + The new property only gets the private key from the privdata; the + public key is provided as a parameter, and so is available as + Info that other properties can use. + * Ssh.keyImported' is renamed to Ssh.userKeyAt, and also changed + to only import the private key from the privdata. (API change) + * While Ssh.keyImported and Ssh.keyImported' avoided updating existing + keys, the new Ssh.userKeys and Ssh.userKeyAt properties will + always update out of date key files. + * Ssh.pubKey renamed to Ssh.hostPubKey. (API change) + * Added --unset-unused + * Fix typo: propigate → propagate. Thanks, Felix Gruber. + (A minor API change) + * Chroot: Converted to use a ChrootBootstrapper type class, so + other ways to bootstrap chroots can easily be added in separate + modules. (API change) + + -- Joey Hess <id@joeyh.name> Tue, 20 Oct 2015 15:43:12 -0400 + +propellor (2.8.1) unstable; urgency=medium + + * Guard against power loss etc when building propellor, by updating + the executable atomically. + * Added Logcheck module, contributed by Jelmer Vernooij. + * Added Kerberos module, contributed by Jelmer Vernooij. + * Privdata that uses HostContext inside a container will now have the + name of the container as its context, rather than the name of + the host(s) where the container is used. This allows eg, having different + passwords for a user in different containers. Note that previously, + propellor would prompt using the container name as the context, but + not actually use privdata using that context; so this is a bug fix. + * Fix --add-key to not fail committing when no privdata file exists yet. + + -- Joey Hess <id@joeyh.name> Sun, 04 Oct 2015 13:54:59 -0400 + +propellor (2.8.0) unstable; urgency=medium + + * Added Propellor.Property.Rsync. + * Convert Info to use Data.Dynamic, so properties can export and consume + info of any type that is Typeable and a Monoid, including data types + private to a module. (API change) + Thanks to Joachim Breitner for the idea. + * Improve propellor wrapper to better handle installation cloning + the public propellor repo, by setting that repo to be upstream, + so propellor doesnt try to push to a read-only repo. + * Added DebianMirror module, contributed by Félix Sipma. + * Some hlint cleanups. + Thanks, Mario Lang + * Added Propellor.Property.Unbound for the caching DNS server. + Thanks, Félix Sipma. + * Added PTR to Dns.Record. While this is ignored by + Propellor.Property.Dns for now, since reverse DNS setup is not + implemented there yet, it can be used in other places, eg Unbound. + Thanks, Félix Sipma. + * PrivData converted to newtype (API change). + * Stopped stripping trailing newlines when setting PrivData; + this was previously done to avoid mistakes when pasting eg passwords + with an unwanted newline. Instead, PrivData consumers should use either + privDataLines or privDataVal, to extract respectively lines or a + value (without internal newlines) from PrivData. + * Allow storing arbitrary ByteStrings in PrivData, extracted using + privDataByteString. + * Added Aiccu module, contributed by Jelmer Vernooij. + * Added --rm-key. + + -- Joey Hess <id@joeyh.name> Tue, 22 Sep 2015 19:35:07 -0400 + +propellor (2.7.3) unstable; urgency=medium + + * Fix bug that caused provisioning new chroots to fail. + * Update for Debian systemd-container package split. + * Added Propellor.Property.Parted, for disk partitioning. + * Added Propellor.Property.Partition, for partition formatting etc. + * Added Propellor.Property.DiskImage, for bootable disk image creation. + (Experimental and not yet complete.) + * Dropped support for ghc 7.4. + + -- Joey Hess <id@joeyh.name> Thu, 03 Sep 2015 08:52:51 -0700 + +propellor (2.7.2) unstable; urgency=medium + + * Added Propellor.Property.ConfFile, with support for Windows-style .ini + files, and generic support for files containing some sort of sections. + Thanks, Sean Whitton for completing the implementation. + * Added Propellor.Property.LightDM + Thanks, Sean Whitton. + * Multiple Tor.hiddenService properties can now be defined for a host; + previously only one such property worked per host. + Thanks, Félix Sipma. + + -- Joey Hess <id@joeyh.name> Tue, 25 Aug 2015 12:00:25 -0700 + +propellor (2.7.1) unstable; urgency=medium + + * Make sure that make is installed when bootstrapping propellor. + * Fix bug in Firewall's Port datatype to iptable parameter translation code. + Thanks, Antoine Eiche. + + -- Joey Hess <id@joeyh.name> Fri, 14 Aug 2015 15:01:37 -0400 + +propellor (2.7.0) unstable; urgency=medium + + * Ssh.permitRootLogin type changed to allow configuring WithoutPassword + and ForcedCommandsOnly (API change) + * setSshdConfig type changed, and setSshdConfigBool added with old type. + * Fix a bug in shim generation code for docker and chroots, that + sometimes prevented deployment of docker containers. + * Added onChangeFlagOnFail which is often a safer alternative to + onChange. + Thanks, Antoine Eiche. + * Work around broken git pull option parser in git 2.5.0, + which broke use of --upload-pack to send a git push when running + propellor --spin. + + -- Joey Hess <id@joeyh.name> Thu, 30 Jul 2015 12:05:46 -0400 + +propellor (2.6.0) unstable; urgency=medium + + * Replace String type synonym Docker.Image by a data type + which allows to specify an image name and an optional tag. (API change) + Thanks, Antoine Eiche. + * Added --unset to delete a privdata field. + * Version dependency on exceptions. + * Systemd: Add masked property. + Thanks, Sean Whitton + * Fix make install target to work even when git is not configured. + + -- Joey Hess <id@joeyh.name> Fri, 10 Jul 2015 22:36:29 -0400 + +propellor (2.5.0) unstable; urgency=medium + + * cmdProperty' renamed to cmdPropertyEnv to make way for a new, + more generic cmdProperty' (API change) + * Add docker image related properties. + Thanks, Antoine Eiche. + * Export CommandParam, boolSystem, safeSystem, shellEscape, and + createProcess from Propellor.Property.Cmd, so they are available + for use in constricting your own Properties when using propellor + as a library. + * Improve enter-machine scripts for systemd-nspawn containers to unset most + environment variables. + * Fix Postfix.satellite bug; the default relayhost was set to the + domain, not to smtp.domain as documented. + * Mount /proc inside a chroot before provisioning it, to work around #787227 + * --spin now works when given a short hostname that only resolves to an + ipv6 address. + * Added publish property for systemd-spawn containers, for port publishing. + (Needs systemd version 220.) + * Added bind and bindRo properties for systemd-spawn containers. + * Firewall: Port was changed to a newtype, and the Port and PortRange + constructors of Rules were changed to DPort and DportRange, respectively. + (API change) + * Docker: volume and publish accept Bound FilePath and Bound Port, + respectively. They also continue to accept Strings, for backwards + compatibility. + * Docker: Added environment property. + Thanks Antoine Eiche. + + -- Joey Hess <id@joeyh.name> Tue, 09 Jun 2015 17:08:43 -0400 + +propellor (2.4.0) unstable; urgency=medium + + * Propellor no longer supports Debian wheezy (oldstable). + * Git.bareRepo: Fix bug in calls to userScriptProperty. + Thanks, Jelmer Vernooij. + * Removed Obnam.latestVersion which was only needed for Debian wheezy + backport. + * Merged Utility changes from git-annex. + * Switched from MonadCatchIO-transformers to the newer transformers and + exceptions libraries. + * Ensure build deps are installed before building propellor in --spin + and cron job, even if propellor was already built before, to deal with + upgrades that add new dependencies. + + -- Joey Hess <id@joeyh.name> Wed, 06 May 2015 14:28:59 -0400 + +propellor (2.3.0) unstable; urgency=medium + + * Make propellor resistent to changes to shared libraries, such as libffi, + which might render the propellor binary unable to run. This is dealt with + by checking the binary both when running propellor on a remote host, + and by Cron.runPropellor. If the binary doesn't work, it will be rebuilt. + * Note that since a new switch had to be added to allow testing the binary, + upgrading to this version will cause a rebuild from scratch of propellor. + * Added hasLoginShell and shellEnabled. + * debCdn changed to new httpredir.debian.org official replacement for + http.debian.net. + * API change: Added User and Group newtypes, and Properties that + used to use the type UserName = String were changed to use them. + + -- Joey Hess <id@joeyh.name> Wed, 22 Apr 2015 13:46:24 -0400 + +propellor (2.2.1) unstable; urgency=medium + + * userScriptProperty now passes --shell /bin/sh, so it can be used + even for users with nonstandard shells. + * Fix bug in docker propellor shim setup introduced in last release, + which broke provisioning of new docker containers. + + -- Joey Hess <id@joeyh.name> Thu, 12 Mar 2015 20:08:34 -0400 + +propellor (2.2.0) unstable; urgency=medium + + * When running shimmed (eg in a docker container), + improve process name visible in ps. + * Add shebang to cron.daily etc files. + * Some changes to tor configuration, minor API change. + * Propellor now builds itself, and gets its build dependencies installed + when deploying to a new host, without needing the Makefile. + + -- Joey Hess <id@joeyh.name> Mon, 09 Mar 2015 12:02:31 -0400 + +propellor (2.1.0) unstable; urgency=medium + + * Additional tor properties, including support for making relays, + and naming bridges, relays, etc. + * New Cron.Times data type, which allows Cron.job to install + daily/monthly/weekly jobs that anacron can run. (API change) + * Fix Git.daemonRunning to restart inetd after enabling the git server. + * Ssh.authorizedKey: Make the authorized_keys file and .ssh directory + be owned by the user, not root. + * Ssh.knownHost: Make the .ssh directory be owned by the user, not root. + + -- Joey Hess <id@joeyh.name> Thu, 12 Feb 2015 12:36:26 -0400 + +propellor (2.0.0) unstable; urgency=medium + + * Property has been converted to a GADT, and will be Property NoInfo + or Property HasInfo. + This was done to make sure that ensureProperty is only used on + properties that do not have Info. + Transition guide: + - Change all "Property" to "Property NoInfo" or "Property HasInfo" + (The compiler can tell you if you got it wrong!) + - To construct a RevertableProperty, it is useful to use the new + (<!>) operator + - Constructing a list of properties can be problimatic, since + Property NoInto and Property HasInfo are different types and cannot + appear in the same list. To deal with this, "props" has been added, + and can built up a list of properties of different types, + using the same (&) and (!) operators that are used to build + up a host's properties. + * Add descriptions of how to set missing fields to --list-fields output. + * Properties now form a tree, instead of the flat list used before. + This includes the properties used inside a container. + * Fix info propagation from fallback combinator's second Property. + * Added systemd configuration properties. + * Added journald configuration properties. + * Added more network interface configuration properties. + * Implemented OS.preserveNetwork. + + -- Joey Hess <id@joeyh.name> Sun, 25 Jan 2015 15:23:08 -0400 + +propellor (1.3.2) unstable; urgency=medium + + * SSHFP records are also generated for CNAMES of hosts. + * Merge Utiity modules from git-annex. + * Ignore bogus DNS when spinning the local host. + + -- Joey Hess <id@joeyh.name> Thu, 15 Jan 2015 14:02:07 -0400 + +propellor (1.3.1) unstable; urgency=medium + + * Fix bug that prevented deploying ssh host keys when the file for the + key didn't already exist. + * DNS records for hosts with known ssh public keys now automatically + include SSHFP records. + + -- Joey Hess <id@joeyh.name> Sun, 04 Jan 2015 19:51:34 -0400 + +propellor (1.3.0) unstable; urgency=medium + + * --spin checks if the DNS matches any configured IP address property + of the host, and if not, sshes to the host by IP address. + * Detect #774376 and refuse to use docker if the system is so broken + that docker exec doesn't enter a chroot. + * Update intermediary propellor in --spin --via + * Added support for DNSSEC. + * Ssh.hostKey and Ssh.hostKeys no longer install public keys from + the privdata. Instead, the public keys are included in the + configuration. (API change) + * Ssh.hostKeys now removes any host keys of types that the host is not + configured to have. + * sshPubKey is renamed to Ssh.pubKey, and has an added SshKeyType + parameter. (API change) + * CloudAtCost.deCruft no longer forces randomHostKeys. + * Fix build with process 1.2.1.0. + + -- Joey Hess <id@joeyh.name> Sun, 04 Jan 2015 17:17:44 -0400 + +propellor (1.2.2) unstable; urgency=medium + + * Revert ensureProperty warning message, too many false positives in places + where Info is correctly propagated. Better approach needed. + + -- Joey Hess <id@joeyh.name> Sun, 21 Dec 2014 21:41:11 -0400 + +propellor (1.2.1) unstable; urgency=medium + + * Added CryptPassword to PrivDataField, for password hashes as produced + by crypt(3). + * User.hasPassword and User.hasSomePassword will now use either + a CryptPassword or a Password from privdata, depending on which is set. + + -- Joey Hess <id@joeyh.name> Wed, 17 Dec 2014 16:30:44 -0400 + +propellor (1.2.0) unstable; urgency=medium + + * Display a warning when ensureProperty is used on a property which has + Info and is so prevented from propigating it. + * Removed boolProperty; instead the new toResult can be used. (API change) + * Include Propellor.Property.OS, which was accidentially left out of the + cabal file in the last release. + * Fix Apache.siteEnabled to update the config file and reload apache when + configuration has changed. + + -- Joey Hess <id@joeyh.name> Tue, 09 Dec 2014 00:05:09 -0400 + +propellor (1.1.0) unstable; urgency=medium + + * --spin target --via relay causes propellor to bounce through an + intermediate relay host, which handles any necessary uploads + when provisioning the target host. + * --spin can be passed multiple hosts, and it will provision each host + in turn. + * Add --merge, to combine multiple --spin commits into a single, more useful + commit. + * Hostname parameters not containing dots are looked up in the DNS to + find the full hostname. + * propellor --spin can now deploy propellor to hosts that do not have + git, ghc, or apt-get. This is accomplished by uploading a fairly + portable precompiled tarball of propellor. + * Propellor.Property.OS contains properties that can be used to do a clean + reinstall of the OS of an existing host. This can be used, for example, + to do an in-place conversion from Fedora to Debian. + This is experimental; use with caution! + * Added group-related properties. Thanks, Félix Sipma. + * Added Git.barerepo. Thanks, Félix Sipma. + * Added Grub.installed and Grub.boots properties. + * New HostContext can be specified when a PrivData value varies per host. + * hasSomePassword and hasPassword now default to using HostContext. + To specify a different context, use hasSomePassword' and + hasPassword' (API change) + * hasSomePassword and hasPassword now make sure shadow passwords are enabled. + * cron.runPropellor now runs propellor, rather than using its Makefile. + This is more robust. + * propellor.debug can be set in the git config to enable more persistent + debugging output. + * Run apt-cache policy with LANG=C so it works on other locales. + * endAction can be used to register an action to run once propellor + has successfully run on a host. + + -- Joey Hess <id@joeyh.name> Sun, 07 Dec 2014 15:23:59 -0400 + +propellor (1.0.0) unstable; urgency=medium + + * propellor --spin can now be used to update remote hosts, without + any central git repository needed. The central git repository is + still useful for running propellor from cron, but this simplifies + getting started with propellor, and allows for more ad-hoc usage. + * The git repo url, if any, is updated whenever propellor --spin is used. + * Added prosody module, contributed by Félix Sipma. + * Can be used to configure tor hidden services. Thanks, Félix Sipma. + * When multiple gpg keys are added, ensure that the privdata file + can be decrypted by all of them. + * Convert GpgKeyId to newtype. (API change) + * DigitalOcean.distroKernel property now reboots into the distribution + kernel when necessary. + * Avoid outputting color setting sequences when not run on a terminal. + * Docker code simplified by using `docker exec`; needs docker 1.3.1. + * Docker containers are now a separate data type, cannot be included + in the main host list, and are instead passed to + Docker.docked. (API change) + * Added support for using debootstrap from propellor. + * Propellor can now be used to provision chroots. + * systemd-nspawn containers can now be managed by propellor, very similar + to its handling of docker containers. + * Debian package will be maintained by Gergely Nagy. + + -- Joey Hess <id@joeyh.name> Fri, 21 Nov 2014 20:58:02 -0400 + +propellor (0.9.2) unstable; urgency=medium + + * Added nginx module, contributed by Félix Sipma. + * Added firewall module, contributed by Arnaud Bailly. + * Apache: Fix daemon reload when enabling a new module or site. + * Docker: Stop using docker.io; that was a compat symlink in + the Debian package which has been removed in docker.io 1.3.1~dfsg1-2. + Closes: #769452 + * Orphaned the Debian package, as I am retiring from Debian. + + -- Joey Hess <joeyh@debian.org> Sat, 08 Nov 2014 15:57:36 -0400 + +propellor (0.9.1) unstable; urgency=medium + + * Docker: Add ability to control when containers restart. + * Docker: Default to always restarting containers, so they come back + up after reboots and docker daemon upgrades. (API change) + * Fix loop when a docker host that does not exist was docked. + + -- Joey Hess <joeyh@debian.org> Fri, 24 Oct 2014 09:57:31 -0400 + +propellor (0.9.0) unstable; urgency=medium + + * Avoid encoding the current stable suite in propellor's code, + since that poses a difficult transition around the release, + and can easily be wrong if an older version of propellor is used. + Instead, the os property for a stable system includes the suite name + to use, eg Stable "wheezy". + * stdSourcesList uses the stable suite name, to avoid unwanted + immediate upgrades to the next stable release. (API change) + * debCdn switched from cdn.debian.net to http.debian.net, which seems to be + better managed now. + * Docker: Avoid committing container every time it's started up. + + -- Joey Hess <joeyh@debian.org> Fri, 10 Oct 2014 11:37:45 -0400 + +propellor (0.8.3) unstable; urgency=medium + + * The Debian package now includes a single-revision git repository in + /usr/src/propellor/, and ~/.propellor/ is set up to use this repository as + its origin remote. This avoids relying on the security of the github + repository when using the Debian package. + * The /usr/bin/propellor wrapper will warn when ~/.propellor/ is out of date + and a newer version is available, after which git merge upstream/master + can be run to merge it. + * Included the config.hs symlink to config-simple.hs in the cabal and Debian + packages. + + -- Joey Hess <joeyh@debian.org> Fri, 22 Aug 2014 13:02:01 -0400 + +propellor (0.8.2) unstable; urgency=medium + + * Fix bug in File.containsLines that caused lines that were already in the + file to sometimes be appended to the end. + * Hostname.sane also configures /etc/mailname. + * Fixed Postfix.satellite to really configure relayhost = smtp.domain. + * Avoid reconfiguring postfix unncessarily when it already has a relayhost. + * Deal with apache 2.4's change in the name of site-available config files. + * Hostname aliases can now be used in several places, including --spin + and Ssh.knownHost. + + -- Joey Hess <joeyh@debian.org> Mon, 04 Aug 2014 01:12:19 -0400 + +propellor (0.8.1) unstable; urgency=medium + + * Run apt-get update in initial bootstrap. + * --list-fields now includes a table of fields that are not currently set, + but would be used if they got set. + * Remove .gitignore from cabal file list, to avoid build failure on Debian. + Closes: #754334 + + -- Joey Hess <joeyh@debian.org> Wed, 09 Jul 2014 22:11:31 -0400 + +propellor (0.8.0) unstable; urgency=medium + + * Completely reworked privdata storage. There is now a single file, + and each host is sent only the privdata that its Properties actually use. + + To transition existing privdata, run propellor against a host and + watch out for the red failure messages, and run the suggested commands + to store the privdata using the new storage scheme. You may find + it useful to run the old version of propellor to extract data from the old + privdata files during this migration. + + Several properties that use privdata now require a context to be + specified. If in doubt, you can use anyContext, or + Context "hostname.example.com" + + * Add --edit to edit a privdata value in $EDITOR. + * Add --list-fields to list all currently set privdata fields, along with + the hosts that use them. + * Fix randomHostKeys property to run openssh-server's postinst in a + non-failing way. + * Hostname.sane now cleans up the 127.0.0.1 localhost line in /etc/hosts, + to avoid eg, apache complaining "Could not reliably determine the + server's fully qualified domain name". + + -- Joey Hess <joeyh@debian.org> Sun, 06 Jul 2014 18:28:08 -0400 + +propellor (0.7.0) unstable; urgency=medium + + * combineProperties no longer stops when a property fails; now it continues + trying to satisfy all properties on the list before propigating the + failure. + * Attr is renamed to Info. (API change) + * Renamed wrapper to propellor to make cabal installation of propellor work. + * When git gpg signature of a fetched git branch cannot be verified, + propellor will now continue running, but without merging in that branch. + + -- Joey Hess <joeyh@debian.org> Fri, 13 Jun 2014 10:06:40 -0400 + +propellor (0.6.0) unstable; urgency=medium + + * Docker containers now propagate DNS attributes out to the host they're + docked in. So if a docker container sets a DNS alias, every container + it's docked in will automatically be added to a DNS round-robin, + when propellor is used to manage DNS for the domain. + * Apt.stdSourcesList no longer needs a suite to be specified. (API change) + * Added --dump to dump out a field of a host's privdata. Useful for editing + it. + * Propellor's output now includes the hostname being provisioned, or + when provisioning a docker container, the container name. + + -- Joey Hess <joeyh@debian.org> Thu, 05 Jun 2014 17:32:14 -0400 + +propellor (0.5.3) unstable; urgency=medium + + * Fix unattended-upgrades config for !stable. + * Ensure that kernel hostname is same as /etc/hostname when configuring + hostname. + * Added modules for some hosting providers (DigitalOcean, CloudAtCost). + + -- Joey Hess <joeyh@debian.org> Thu, 29 May 2014 14:29:53 -0400 + +propellor (0.5.2) unstable; urgency=medium + + * A bug that caused propellor to hang when updating a running docker + container appears to have been fixed. Note that since it affects + the propellor process that serves as "init" of docker containers, + they have to be restarted for the fix to take effect. + * Licence changed from GPL to BSD. + * A few changes to allow building Propellor on OSX. One user reports + successfully using it there. + + -- Joey Hess <joeyh@debian.org> Sat, 17 May 2014 16:42:55 -0400 + +propellor (0.5.1) unstable; urgency=medium + + * Primary DNS servers now have allow-transfer automatically populated + with the IP addresses of secondary dns servers. So, it's important + that all secondary DNS servers have an ipv4 (and/or ipv6) property + configured. + * Deal with old ssh connection caching sockets. + * Add missing build deps and deps. Closes: #745459 + + -- Joey Hess <joeyh@debian.org> Thu, 24 Apr 2014 18:09:58 -0400 + +propellor (0.5.0) unstable; urgency=medium + + * Removed root domain records from SOA. Instead, use RootDomain + when calling Dns.primary. (API change) + * Dns primary and secondary properties are now revertable. + * When unattendedUpgrades is enabled on an Unstable or Testing system, + configure it to allow the upgrades. + * New website, https://propellor.branchable.com/ + + -- Joey Hess <joeyh@debian.org> Sat, 19 Apr 2014 17:38:02 -0400 + +propellor (0.4.0) unstable; urgency=medium + + * Propellor can configure primary DNS servers, including generating + zone files, which is done by looking at the properties of hosts + in a domain. + * The `cname` property was renamed to `alias` as it does not always + generate CNAME in the DNS. (API change) + * Constructor of Property has changed (use `property` function instead). + (API change) + * All Property combinators now combine together their Attr settings. + So Attr settings can be made inside a propertyList, for example. + * Run all cron jobs under chronic from moreutils to avoid unnecessary + mails. + + -- Joey Hess <joeyh@debian.org> Sat, 19 Apr 2014 02:09:56 -0400 + +propellor (0.3.1) unstable; urgency=medium + + * Merge scheduler bug fix from git-annex. + * Support for provisioning hosts with ssh and gpg keys. + * Obnam support. + * Apache support. + * Postfix satellite system support. + * Properties can now be satisfied differently on different operating + systems. + * Standard apt configuration for stable now includes backports. + * Cron jobs generated by propellor use flock(1) to avoid multiple + instances running at a time. + * Add support for SSH ed25519 keys. + (Thanks, Franz Pletz.) + + -- Joey Hess <joeyh@debian.org> Thu, 17 Apr 2014 20:07:33 -0400 + +propellor (0.3.0) unstable; urgency=medium + + * ipv6to4: Ensure interface is brought up automatically on boot. + * Enabling unattended upgrades now ensures that cron is installed and + running to perform them. + * Properties can be scheduled to only be checked after a given time period. + * Fix bootstrapping of dependencies. + * Fix compilation on Debian stable. + * Include security updates in sources.list for stable and testing. + * Use ssh connection caching, especially when bootstrapping. + * Properties now run in a Propellor monad, which provides access to + attributes of the host. (API change) + + -- Joey Hess <joeyh@debian.org> Fri, 11 Apr 2014 01:19:05 -0400 + +propellor (0.2.3) unstable; urgency=medium + + * docker: Fix laziness bug that caused running containers to be + unnecessarily stopped and committed. + * Add locking so only one propellor can run at a time on a host. + * docker: When running as effective init inside container, wait on zombies. + * docker: Added support for configuring shared volumes and linked + containers. + + -- Joey Hess <joeyh@debian.org> Tue, 08 Apr 2014 02:07:37 -0400 + +propellor (0.2.2) unstable; urgency=medium + + * Now supports provisioning docker containers with architecture/libraries + that do not match the host. + * Fixed a bug that caused file modes to be set to 600 when propellor + modified the file (did not affect newly created files). + + -- Joey Hess <joeyh@debian.org> Fri, 04 Apr 2014 01:07:32 -0400 + +propellor (0.2.1) unstable; urgency=medium + + * First release with Debian package. + + -- Joey Hess <joeyh@debian.org> Thu, 03 Apr 2014 01:43:14 -0400 + +propellor (0.2.0) unstable; urgency=low + + * Added support for provisioning Docker containers. + * Bootstrap deployment now pushes the git repo to the remote host + over ssh, securely. + * propellor --add-key configures a gpg key, and makes propellor refuse + to pull commits from git repositories not signed with that key. + This allows propellor to be securely used with public, non-encrypted + git repositories without the possibility of MITM. + * Added support for type-safe reversions. Only some properties can be + reverted; the type checker will tell you if you try something that won't + work. + * New syntactic sugar for building a list of properties, including + revertable properties. + + -- Joey Hess <joeyh@debian.org> Wed, 02 Apr 2014 13:57:42 -0400 diff --git a/debian/compat b/debian/compat @@ -0,0 +1 @@ +9 diff --git a/debian/control b/debian/control @@ -0,0 +1,134 @@ +Source: propellor +Section: admin +Priority: optional +Build-Depends: + cabal-install, + cdbs, + debhelper (>= 9), + ghc (>= 7.6), + git, + haskell-devscripts, + libghc-ansi-terminal-dev, + libghc-ansi-terminal-prof, + libghc-async-dev, + libghc-async-prof, + libghc-concurrent-output-dev, + libghc-concurrent-output-prof, + libghc-exceptions-dev (>= 0.6), + libghc-exceptions-prof (>= 0.6), + 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-stm-dev, + libghc-stm-prof, + libghc-text-dev, + libghc-text-prof, + libghc-transformers-dev, + libghc-transformers-prof, + libghc-unix-compat-dev, + libghc-unix-compat-prof, +Maintainer: Sean Whitton <spwhitton@spwhitton.name> +Standards-Version: 3.9.8 +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 +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. + . + It is configured using haskell. + . + The easiest way to get started with propellor is to install the binary package + `propellor' and run `propellor --init'. + +Package: libghc-propellor-dev +Section: haskell +Architecture: any +Depends: + ${haskell:Depends}, + ${misc:Depends}, + ${shlibs:Depends}, +Recommends: + ${haskell:Recommends}, +Suggests: + ${haskell:Suggests}, +Conflicts: + ${haskell:Conflicts}, +Provides: + ${haskell:Provides}, +Description: ${haskell:ShortDescription}${haskell:ShortBlurb} + ${haskell:LongDescription} + . + ${haskell:Blurb} + +Package: libghc-propellor-doc +Architecture: all +Section: doc +Depends: + ${haskell:Depends}, + ${misc:Depends}, +Recommends: + ${haskell:Recommends}, +Suggests: + ${haskell:Suggests}, +Conflicts: + ${haskell:Conflicts}, +Description: ${haskell:ShortDescription}${haskell:ShortBlurb} + ${haskell:LongDescription} + . + ${haskell:Blurb} + +Package: libghc-propellor-prof +Section: haskell +Architecture: any +Depends: + ${haskell:Depends}, + ${misc:Depends}, +Recommends: + ${haskell:Recommends}, +Suggests: + ${haskell:Suggests}, +Conflicts: + ${haskell:Conflicts}, +Provides: + ${haskell:Provides}, +Description: ${haskell:ShortDescription}${haskell:ShortBlurb} + ${haskell:LongDescription} + . + ${haskell:Blurb} + +Package: propellor +Architecture: any +Depends: + cabal-install, + ghc (>= 7.4), + git (>= 1:2.9), + libghc-ansi-terminal-dev, + libghc-async-dev, + libghc-concurrent-output-dev, + libghc-exceptions-dev (>= 0.6), + libghc-hslogger-dev, + libghc-ifelse-dev, + libghc-missingh-dev, + libghc-mtl-dev, + libghc-network-dev, + libghc-propellor-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 + 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. + . + It is configured using haskell. diff --git a/debian/copyright b/debian/copyright @@ -0,0 +1,28 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: https://propellor.branchable.com/ + +Files: * +Copyright: © 2010-2016 Joey Hess <id@joeyh.name> and contributors +License: BSD-2-clause + +License: BSD-2-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. diff --git a/debian/lintian-overrides b/debian/lintian-overrides diff --git a/debian/propellor.README.Debian b/debian/propellor.README.Debian @@ -0,0 +1,14 @@ +The Debian package of propellor ships its full source code because +propellor is configured by rebuilding it, and embraces modification of any +of the source code. + +/usr/bin/propellor is a wrapper which will set up a propellor git +repository in ~/.propellor/, and run ~/.propellor/propellor if it exists. +Edit ~/.propellor/config.hs to configure it. + +Note that upgrading the propellor package will not update your +~/.propellor/ repository. This is because you may have local changes +to the source, or may need to adapt your config.hs to work with the new +version of propellor. Instead, if your ~/.propellor/ is from an older +version of propellor, /usr/bin/propellor will warn that it's out of date, +and tell you how to merge in the changes. diff --git a/debian/rules b/debian/rules @@ -0,0 +1,15 @@ +#!/usr/bin/make -f + +# don't install CHANGELOG as it duplicates d/changelog +DEB_INSTALL_CHANGELOGS_ALL=-XCHANGELOG + +# Avoid using cabal, as it writes to $HOME +export CABAL=./Setup + +build/propellor:: + $(MAKE) build +install/propellor:: + DESTDIR=$(CURDIR)/debian/propellor $(MAKE) install + +include /usr/share/cdbs/1/rules/debhelper.mk +include /usr/share/cdbs/1/class/hlibrary.mk diff --git a/doc/README.mdwn b/doc/README.mdwn @@ -0,0 +1,56 @@ +[Propellor](https://propellor.branchable.com/) is a +configuration management system using Haskell and Git. +Each system has a list of properties, which Propellor ensures +are satisfied. +[Linux](http://propellor.branchable.com/Linux/) and +[FreeBSD](http://propellor.branchable.com/FreeBSD/) are supported. + +Propellor is configured via a git repository, which typically lives +in `~/.propellor/` on your development machine. Propellor clones the +repository to each host it manages, in a +[secure](http://propellor.branchable.com/security/) way. See +[components](http://propellor.branchable.com/components/) +for details. + +Properties are defined using Haskell. Edit `~/.propellor/config.hs` +to get started. 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) +and +[Apache](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apache.html) +, +[Cron](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cron.html) +and +[Commands](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cmd.html) +, +[Dns](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Dns.html) +and +[Docker](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Docker.html), etc. + +There is no special language as used in puppet, chef, ansible, etc.. just +the full power of Haskell. Hopefully that power can be put to good use in +making declarative properties that are powerful, nicely idempotent, and +easy to adapt to a system's special needs! + +If using Haskell to configure Propellor seems intimidating, +see [configuration for the Haskell newbie](https://propellor.branchable.com/haskell_newbie/). + +## quick start + +1. Get propellor installed on your development machine (ie, laptop). + `cabal install propellor` + or + `apt-get install propellor` +2. Run `propellor --init` ; this will set up a `~/.propellor/` git + repository for you. +3. Edit `~/.propellor/config.hs`, and add a host you want to manage. + You can start by not adding any properties, or only a few. +4. Run: `propellor --spin $HOST` +5. Now you have a simple propellor deployment to a host. Continue editing + `~/.propellor/config.hs` to further configure the host, add more hosts + etc, and re-run `propellor --spin $HOST` after each change. +6. Once you have a lot of hosts, and running `propellor --spin HOST` for + each host becomes tiresome, you can + [automate that](http://propellor.branchable.com/automated_spins/). +7. Write some neat new properties and send patches! diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -0,0 +1,658 @@ +-- This is the live config file used by propellor's author. +-- https://propellor.branchable.com/ +module Main where + +import Propellor +import Propellor.Property.Scheduled +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Network as Network +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.Ssh as Ssh +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.Tor as Tor +import qualified Propellor.Property.Dns as Dns +import qualified Propellor.Property.OpenId as OpenId +import qualified Propellor.Property.Git as Git +import qualified Propellor.Property.Postfix as Postfix +import qualified Propellor.Property.Apache as Apache +import qualified Propellor.Property.LetsEncrypt as LetsEncrypt +import qualified Propellor.Property.Grub as Grub +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 +import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost +import qualified Propellor.Property.HostingProvider.Linode as Linode +import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean +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`/__| (____.' + {- Propellor -- \ / | / ) _.-"-._ + Deployed -} -- `/-==__ _/__|/__=-| ( \_ +hosts :: [Host] -- * \ | | '--------' +hosts = -- (o) ` + [ darkstar + , gnu + , clam + , mayfly + , oyster + , orca + , honeybee + , kite + , elephant + , beaver + , pell + , keysafe + ] ++ monsters + +testvm :: Host +testvm = host "testvm.kitenet.net" $ props + & osDebian Unstable X86_64 + & OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net") + `onChange` postinstall + & Hostname.sane + & Hostname.searchDomain + & Apt.installed ["linux-image-amd64"] + & Apt.installed ["ssh"] + & User.hasPassword (User "root") + where + postinstall :: Property DebianLike + postinstall = propertyList "fixing up after clean install" $ props + & OS.preserveRootSshAuthorized + & OS.preserveResolvConf + & Apt.update + & Grub.boots "/dev/sda" + `requires` Grub.installed Grub.PC + +darkstar :: Host +darkstar = host "darkstar.kitenet.net" $ props + & ipv6 "2001:4830:1600:187::2" + & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" + + & Apt.buildDep ["git-annex"] `period` Daily + + & JoeySites.dkimMilter + & 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) + [ partition EXT2 `mountedAt` "/boot" + `setFlag` BootFlag + , partition EXT4 `mountedAt` "/" + `mountOpt` errorReadonly + , swapPartition (MegaBytes 256) + ] + where + c d = Chroot.debootstrapped mempty d $ props + & osDebian Unstable X86_64 + & Hostname.setTo "demo" + & Apt.installed ["linux-image-amd64"] + & User "root" `User.hasInsecurePassword` "root" + +gnu :: Host +gnu = host "gnu.kitenet.net" $ props + & Apt.buildDep ["git-annex"] `period` Daily + +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" + + & CloudAtCost.decruft + & Ssh.hostKeys hostContext + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAI3WUq0RaigLlcUivgNG4sXpso2ORZkMvfqKz6zkc60L6dpxvWDNmZVEH8hEjxRSYG07NehcuOgQqeyFnS++xw1hdeGjf37JqCUH49i02lra3Zxv8oPpRxyeqe5MmuzUJhlWvBdlc3O/nqZ4bTUfnxMzSYWyy6++s/BpSHttZplNAAAAFQC1DE0vzgVeNAv9smHLObQWZFe2VQAAAIBECtpJry3GC8NVTFsTHDGWksluoFPIbKiZUFFztZGdM0AO2VwAbiJ6Au6M3VddGFANgTlni6d2/9yS919zO90TaFoIjywZeXhxE2CSuRfU7sx2hqDBk73jlycem/ER0sanFhzpHVpwmLfWneTXImWyq37vhAxatJANOtbj81vQ3AAAAIBV3lcyTT9xWg1Q4vERJbvyF8mCliwZmnIPa7ohveKkxlcgUk5d6dnaqFfjVaiXBPN3Qd08WXoQ/a9k3chBPT9nW2vWgzzM8l36j2MbHLmaxGwevAc9+vx4MXqvnGHzd2ex950mC33ct3j0fzMZlO6vqEsgD4CYmiASxhfefj+JCQ==") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDJybAjUPUWIhvVMmer8K5ZgdfI54DM6vc8Mzw+5KmVKL0TwkvzbR1HAB4heyMGtN1F8YzkWhsI3/Txh+MQUJ+i4u8SvSYc6D1q3j3ZyCi06wZ3DJS25tZrOM/thOOA1DFA4Hhb0uI/1Kg8PguNNNSMXn8F7q3F6cFQizYgszs6z6ktiST/BTC+IXWovhcnn2vQXXU8FTcTsqBFqA5dEjZbp1WDzqp3km84ZyXGmoVlpqzXeMvlkWTIshYiQjXIwPOkALzlGYjp1lw1OaxPVI1IGFcgCbIWQQWoCReb+genX2VaR+odAYXjaOdRx0lQj7UCPTBCpqMyzBMLtT5Yiaqh") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBPhfvcOuw0Yt+MnsFc4TI2gWkKi62Eajxz+TgbHMO/uRTYF8c5V8fOI3o+J/3m5+lT0S5o8j8a7xIC3COvi+AVw=") + ] + & Apt.unattendedUpgrades + & Network.ipv6to4 + & Systemd.persistentJournal + & Journald.systemMaxUse "500MiB" + + & 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 + & 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 + & 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 + & standardSystem Unstable X86_64 [ "Main git-annex build box." ] + & ipv4 "138.38.108.179" + + & Apt.unattendedUpgrades + & Postfix.satellite + & Apt.serviceInstalledRunning "ntp" + & Systemd.persistentJournal + + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.standardAutoBuilder + Unstable X86_64 Nothing (Cron.Times "15 * * * *") "2h") + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.standardAutoBuilder + Unstable X86_32 Nothing (Cron.Times "30 * * * *") "2h") + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.stackAutoBuilder + (Stable "jessie") X86_32 (Just "ancient") (Cron.Times "45 * * * *") "2h") + & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer + (Cron.Times "1 1 * * *") "3h") + +honeybee :: Host +honeybee = host "honeybee.kitenet.net" $ props + & standardSystem Testing ARMHF [ "Arm git-annex build box." ] + + -- I have to travel to get console access, so no automatic + -- upgrades, and try to be robust. + & "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes" + + & 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 + + -- 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. + & Apt.serviceInstalledRunning "ntp" + + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.armAutoBuilder + Unstable ARMEL Nothing Cron.Daily "22h") + +-- This is not a complete description of kite, since it's a +-- multiuser system with eg, user passwords that are not deployed +-- with propellor. +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" + & alias "kitenet.net" + & alias "wren.kitenet.net" -- temporary + & Ssh.hostKeys (Context "kitenet.net") + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAO9tnPUT4p+9z7K6/OYuiBNHaij4Nzv5YVBih1vMl+ALz0gYAj8RWJzXmqp5buFAyfgOoLw+H9s1bBS01Sy3i07Dm6cx1fWG4RXL/E/3w1tavX99GD2bBxDBu890ebA5Tp+eFRJkS9+JwSvFiF6CP7NbVjifCagoUO56Ig048RwDAAAAFQDPY2xM3q6KwsVQliel23nrd0rV2QAAAIEAga3hj1hL00rYPNnAUzT8GAaSP62S4W68lusErH+KPbsMwFBFY/Ib1FVf8k6Zn6dZLh/HH/RtJi0JwdzPI1IFW+lwVbKfwBvhQ1lw9cH2rs1UIVgi7Wxdgfy8gEWxf+QIqn62wG+Ulf/HkWGvTrRpoJqlYRNS/gnOWj9Z/4s99koAAACBAM/uJIo2I0nK15wXiTYs/NYUZA7wcErugFn70TRbSgduIFH6U/CQa3rgHJw9DCPCQJLq7pwCnFH7too/qaK+czDk04PsgqV0+Jc7957gU5miPg50d60eJMctHV4eQ1FpwmGGfXxRBR9k2ZvikWYatYir3L6/x1ir7M0bA9IzNU45") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAIEA2QAJEuvbTmaN9ex9i9bjPhMGj+PHUYq2keIiaIImJ+8mo+yKSaGUxebG4tpuDPx6KZjdycyJt74IXfn1voGUrfzwaEY9NkqOP3v6OWTC3QeUGqDCeJ2ipslbEd9Ep9XBp+/ldDQm60D0XsIZdmDeN6MrHSbKF4fXv1bqpUoUILk=") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBLF+dzqBJZix+CWUkAd3Bd3cofFCKwHMNRIfwx1G7dL4XFe6fMKxmrNetQcodo2edyufwoPmCPr3NmnwON9vyh0=") + , (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3") + ] + + & Network.static "eth0" `requires` Network.cleanInterfacesFile + & Apt.installed ["linux-image-amd64"] + & Linode.serialGrub + & Linode.mlocateEnabled + & Apt.unattendedUpgrades + & Systemd.installed + & Systemd.persistentJournal + & Journald.systemMaxUse "500MiB" + & Ssh.passwordAuthentication True + & Fail2Ban.installed -- since ssh password authentication is allowed + & Apt.serviceInstalledRunning "ntp" + & "/etc/timezone" `File.hasContent` ["US/Eastern"] + + & Obnam.backupEncrypted "/" (Cron.Times "33 1 * * *") + [ "--repository=sftp://2318@usw-s002.rsync.net/~/kite-root.obnam" + , "--client-name=kitenet.net" + , "--exclude=/home" + , "--exclude=/var/cache" + , "--exclude=/var/tmp" + , "--exclude=/srv/git" + , "--exclude=/var/spool/oldusenet" + , "--exclude=.*/tmp/" + , "--one-file-system" + , Obnam.keepParam [Obnam.KeepDays 7, Obnam.KeepWeeks 4, Obnam.KeepMonths 6] + ] Obnam.OnlyClient (Gpg.GpgKeyId "98147487") + `requires` rootsshkey + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + & Obnam.backupEncrypted "/home" (Cron.Times "33 3 * * *") + [ "--repository=sftp://2318@usw-s002.rsync.net/~/kite-home.obnam" + , "--client-name=kitenet.net" + , "--exclude=/home/joey/lib" + , "--one-file-system" + , Obnam.keepParam [Obnam.KeepDays 7, Obnam.KeepWeeks 4, Obnam.KeepMonths 6] + ] Obnam.OnlyClient (Gpg.GpgKeyId "98147487") + `requires` rootsshkey + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + + & alias "smtp.kitenet.net" + & alias "imap.kitenet.net" + & alias "pop.kitenet.net" + & alias "mail.kitenet.net" + & JoeySites.kiteMailServer + + & JoeySites.legacyWebSites + & File.ownerGroup "/srv/web" (User "joey") (Group "joey") + & Apt.installed ["analog"] + + & alias "git.kitenet.net" + & alias "git.joeyh.name" + & JoeySites.gitServer hosts + + & JoeySites.downloads hosts + & JoeySites.gitAnnexDistributor + & JoeySites.tmp + + & alias "bitlbee.kitenet.net" + & Apt.serviceInstalledRunning "bitlbee" + & "/etc/bitlbee/bitlbee.conf" `File.hasContent` + [ "[settings]" + , "User = bitlbee" + , "AuthMode = Registered" + , "[defaults]" + ] + `onChange` Service.restarted "bitlbee" + & "/etc/default/bitlbee" `File.containsLine` "BITLBEE_PORT=\"6767\"" + `onChange` Service.restarted "bitlbee" + + & Apt.installed + [ "git-annex", "myrepos" + , "build-essential", "make" + , "rss2email", "archivemail" + , "devscripts" + -- Some users have zsh as their login shell. + , "zsh" + ] + + & alias "nntp.olduse.net" + & JoeySites.oldUseNetServer hosts + + & alias "ns4.kitenet.net" + & myDnsPrimary True "kitenet.net" [] + & myDnsPrimary True "joeyh.name" [] + & myDnsPrimary True "ikiwiki.info" [] + & myDnsPrimary True "olduse.net" + [ (RelDomain "article", CNAME $ AbsDomain "virgil.koldfront.dk") + ] + & alias "ns4.branchable.com" + & branchableSecondary + & Dns.secondaryFor ["animx"] hosts "animx.eu.org" + + -- testing + & Apache.httpsVirtualHost "letsencrypt.joeyh.name" "/var/www/html" + (LetsEncrypt.AgreeTOS (Just "id@joeyh.name")) + & alias "letsencrypt.joeyh.name" + where + rootsshkey = Ssh.userKeys (User "root") + (Context "kite.kitenet.net") + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC5Gza2sNqSKfNtUN4dN/Z3rlqw18nijmXFx6df2GtBoZbkIak73uQfDuZLP+AXlyfHocwdkdHEf/zrxgXS4EokQMGLZhJ37Pr3edrEn/NEnqroiffw7kyd7EqaziA6UOezcLTjWGv+Zqg9JhitYs4WWTpNzrPH3yQf1V9FunZnkzb4gJGndts13wGmPEwSuf+QHbgQvjMOMCJwWSNcJGdhDR66hFlxfG26xx50uIczXYAbgLfHp5W6WuR/lcaS9J6i7HAPwcsPDA04XDinrcpl29QwsMW1HyGS/4FSCgrDqNZ2jzP49Bka78iCLRqfl1efyYas/Zo1jQ0x+pxq2RMr root@kite") + ] + +elephant :: Host +elephant = host "elephant.kitenet.net" $ props + & standardSystem Unstable X86_64 + [ "Storage, big data, and backups, omnomnom!" + , "(Encrypt all data stored here.)" + ] + & ipv4 "193.234.225.114" + & Ssh.hostKeys hostContext + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBANxXGWac0Yz58akI3UbLkphAa8VPDCGswTS0CT3D5xWyL9OeArISAi/OKRIvxA4c+9XnWtNXS7nYVFDJmzzg8v3ZMx543AxXK82kXCfvTOc/nAlVz9YKJAA+FmCloxpmOGrdiTx1k36FE+uQgorslGW/QTxnOcO03fDZej/ppJifAAAAFQCnenyJIw6iJB1+zuF/1TSLT8UAeQAAAIEA1WDrI8rKnxnh2rGaQ0nk+lOcVMLEr7AxParnZjgC4wt2mm/BmkF/feI1Fjft2z4D+V1W7MJHOqshliuproxhFUNGgX9fTbstFJf66p7h7OLAlwK8ZkpRk/uV3h5cIUPel6aCwjL5M2gN6/yq+gcCTXeHLq9OPyUTmlN77SBL71UAAACBAJJiCHWxPAGooe7Vv3W7EIBbsDyf7b2kDH3bsIlo+XFcKIN6jysBu4kn9utjFlrlPeHUDzGQHe+DmSqTUQQ0JPCRGcAcuJL8XUqhJi6A6ye51M9hVt51cJMXmERx9TjLOP/adkEuxpv3Fj20FxRUr1HOmvRvewSHrJ1GeA1bjbYL") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCrEQ7aNmRYyLKY7xHILQsyV/w0B3++D98vn5IvjHkDnitrUWjB+vPxlS7LYKLzN9Jx7Hb14R2lg7+wdgtFMxLZZukA8b0tqFpTdRFBvBYGh8IM8Id1iE/6io/NZl+hTQEDp0LJP+RljH1CLfz7J3qtc+v6NbfTP5cOgH104mWYoLWzJGaZ4p53jz6THRWnVXy5nPO3dSBr2f/SQgRuJQWHNIh0jicRGD8H2kzOQzilpo+Y46PWtkufl3Yu3UsP5UMAyLRIXwZ6nNRZqRiVWrX44hoNfDbooTdFobbHlqMl+y6291bOXaOA6PACk8B4IVcC89/gmc9Oe4EaDuszU5kD") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBAJkoPRhUGT8EId6m37uBdYEtq42VNwslKnc9mmO+89ody066q6seHKeFY6ImfwjcyIjM30RTzEwftuVNQnbEB0=") + , (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB6VtXi0uygxZeCo26n6PuCTlSFCBcwRifv6N8HdWh2Z") + ] + + & Grub.chainPVGrub "hd0,0" "xen/xvda1" 30 + & Postfix.satellite + & Apt.unattendedUpgrades + & Systemd.installed + & Systemd.persistentJournal + & Ssh.userKeys (User "joey") hostContext + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC4wJuQEGno+nJvtE75IKL6JQ08sJHZ9Bzs9Dvu0zuxSEZE30MWK98/twNwCH9PVf2N9m4apfN7f9GHgHTUongfo8xnLAk4PuBSTV74YgKyOCvNYqANuKKa+76PsS/vFf/or3ct++uTEWsRyYD29cQndufwKA4rthAqHG+fifbLDC53AjcldI0zI1RckpPzT+AMazlnSBFMlpKvGD2uzSXALVRXa3vSqWkWd0z7qmIkpmpq0AAgbDLwrGBcUGV/h0rOa2s8zSeirA0tLmHNROl4cZsX0T/6VBGfBRkrHSxL67xJziATw4WPq6spYlxg84pC/5qJVr9SC5HosppbDqgj joey@elephant") + ] + & Apt.serviceInstalledRunning "swapspace" + + & alias "eubackup.kitenet.net" + & Apt.installed ["obnam", "sshfs", "rsync"] + & JoeySites.obnamRepos ["pell", "kite"] + & JoeySites.githubBackup + & JoeySites.rsyncNetBackup hosts + + & alias "podcatcher.kitenet.net" + & JoeySites.podcatcher + + & alias "znc.kitenet.net" + & JoeySites.ircBouncer + & alias "kgb.kitenet.net" + & JoeySites.kgbServer + + & alias "mumble.kitenet.net" + & JoeySites.mumbleServer hosts + + & alias "ns3.kitenet.net" + & myDnsSecondary + + & Systemd.nspawned oldusenetShellBox + & Systemd.nspawned ancientKitenet + & Systemd.nspawned openidProvider + `requires` Apt.serviceInstalledRunning "ntp" + + & JoeySites.scrollBox + & alias "scroll.joeyh.name" + & alias "eu.scroll.joeyh.name" + + -- For https port 443, shellinabox with ssh login to + -- kitenet.net + & alias "shell.kitenet.net" + & Systemd.nspawned kiteShellBox + -- 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) + +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==" + & 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/" + +-- Branchable is not completely deployed with propellor yet. +pell :: Host +pell = host "pell.branchable.com" $ props + & alias "branchable.com" + & ipv4 "66.228.46.55" + & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5" + + -- All the websites I host at branchable that don't use + -- branchable.com dns. + & alias "olduse.net" + & alias "www.olduse.net" + & alias "www.kitenet.net" + & alias "joeyh.name" + & alias "www.joeyh.name" + & alias "campaign.joeyh.name" + & alias "ikiwiki.info" + & alias "www.ikiwiki.info" + & alias "git.ikiwiki.info" + & alias "l10n.ikiwiki.info" + & alias "dist-bugs.kitenet.net" + & alias "family.kitenet.net" + + & Apt.installed ["linux-image-amd64"] + & Apt.unattendedUpgrades + & Branchable.server hosts + & Linode.serialGrub + +-- See https://joeyh.name/code/keysafe/servers/ for requirements. +keysafe :: Host +keysafe = host "keysafe.joeyh.name" $ props + & ipv4 "139.59.17.168" + & Hostname.sane + & osDebian (Stable "jessie") X86_64 + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.unattendedUpgrades + & DigitalOcean.distroKernel + -- This is a 500 mb VM, so need more ram to build propellor. + & Apt.serviceInstalledRunning "swapspace" + & Cron.runPropellor (Cron.Times "30 * * * *") + & Apt.installed ["etckeeper", "sudo"] + & Apt.removed ["nfs-common", "exim4", "exim4-base", "exim4-daemon-light", "rsyslog", "acpid", "rpcbind", "at"] + + & User.hasSomePassword (User "root") + & User.accountFor (User "joey") + & User.hasSomePassword (User "joey") + & Sudo.enabledFor (User "joey") + + & Ssh.installed + & Ssh.randomHostKeys + & User "root" `Ssh.authorizedKeysFrom` (User "joey", darkstar) + & User "joey" `Ssh.authorizedKeysFrom` (User "joey", darkstar) + & Ssh.noPasswords + + & Tor.installed + & Tor.hiddenServiceAvailable "keysafe" (Port 4242) + `requires` Tor.hiddenServiceData "keysafe" hostContext + & Tor.bandwidthRate (Tor.PerMonth "750 GB") + + -- keysafe installed manually until package is available + & Systemd.enabled "keysafe" + + & Gpg.keyImported (Gpg.GpgKeyId "CECE11AE") (User "root") + & Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + & Ssh.userKeys (User "root") + (Context "keysafe.joeyh.name") + [ (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIEx8bK9ZbXVEgEvxQeXLjnr9cGa/QvoB459aglP529My root@keysafe") + ] + -- Note that this is not an incremental backup; it uploads the + -- whole content every time. So, only run weekly. + & Cron.niceJob "keysafe backup" Cron.Weekly (User "root") "/" backupcmd + `requires` Apt.installed ["rsync"] + where + datadir = "/var/lib/keysafe" + backupdir = "/var/backups/keysafe" + rsyncnetbackup = "2318@usw-s002.rsync.net:keysafe" + backupcmd = unwords + [ "keysafe --store-directory", datadir, "--backup-server", backupdir + , "&& rsync -a --delete --max-delete 3 ", backupdir , rsyncnetbackup + ] + + --' __|II| ,. + ---- __|II|II|__ ( \_,/\ +--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'- +-------------------------- | [Containers] / -------------------------- +-------------------------- : / --------------------------- +--------------------------- \____, 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") + & alias hn + & OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8081)) + where + hn = "openid.kitenet.net" + +-- Exhibit: kite's 90's website on port 1994. +ancientKitenet :: Systemd.Container +ancientKitenet = Systemd.debContainer "ancient-kitenet" $ props + & standardContainer (Stable "jessie") + & alias hn + & Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html" + (Just "remotes/origin/old-kitenet.net") + & Apache.installed + & Apache.listenPorts [p] + & Apache.virtualHost hn p "/var/www/html" + & Apache.siteDisabled "000-default" + where + p = Port 1994 + hn = "ancient.kitenet.net" + +oldusenetShellBox :: Systemd.Container +oldusenetShellBox = Systemd.debContainer "oldusenet-shellbox" $ props + & standardContainer (Stable "jessie") + & alias "shell.olduse.net" + & JoeySites.oldUseNetShellBox + +kiteShellBox :: Systemd.Container +kiteShellBox = Systemd.debContainer "kiteshellbox" $ props + & standardContainer (Stable "jessie") + & JoeySites.kiteShellBox + +type Motd = [String] + +-- This is my standard system setup. +standardSystem :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian) +standardSystem suite arch motd = + standardSystemUnhardened suite arch motd + `before` Ssh.noPasswords + +standardSystemUnhardened :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian) +standardSystemUnhardened suite arch motd = propertyList "standard system" $ props + & osDebian suite arch + & Hostname.sane + & Hostname.searchDomain + & File.hasContent "/etc/motd" ("":motd++[""]) + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.cacheCleaned + & Apt.installed ["etckeeper"] + & Apt.installed ["ssh", "mosh"] + & GitHome.installedFor (User "root") + & User.hasSomePassword (User "root") + & User.accountFor (User "joey") + & User.hasSomePassword (User "joey") + & Sudo.enabledFor (User "joey") + & GitHome.installedFor (User "joey") + & Apt.installed ["vim", "screen", "less"] + & Cron.runPropellor (Cron.Times "30 * * * *") + -- I use postfix, or no MTA. + & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] + `onChange` Apt.autoRemove + -- At least until system integration catches up, revert + -- systemd 230's behavior of enabling this property by default. + ! Systemd.killUserProcesses + +-- This is my standard container setup, Featuring automatic upgrades. +standardContainer :: DebianSuite -> Property (HasInfo + Debian) +standardContainer suite = propertyList "standard container" $ props + & osDebian suite X86_64 + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.unattendedUpgrades + & Apt.cacheCleaned + +myDnsSecondary :: Property (HasInfo + DebianLike) +myDnsSecondary = propertyList "dns secondary for all my domains" $ props + & Dns.secondary hosts "kitenet.net" + & Dns.secondary hosts "joeyh.name" + & Dns.secondary hosts "ikiwiki.info" + & Dns.secondary hosts "olduse.net" + +branchableSecondary :: RevertableProperty (HasInfo + DebianLike) DebianLike +branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" + +-- Currently using kite (ns4) as primary with secondaries +-- elephant (ns3) and gandi. +-- kite handles all mail. +myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike +myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain + (Dns.mkSOA "ns4.kitenet.net" 100) $ + [ (RootDomain, NS $ AbsDomain "ns4.kitenet.net") + , (RootDomain, NS $ AbsDomain "ns3.kitenet.net") + , (RootDomain, NS $ AbsDomain "ns6.gandi.net") + , (RootDomain, MX 0 $ AbsDomain "kitenet.net") + , (RootDomain, TXT "v=spf1 a a:kitenet.net ~all") + , JoeySites.domainKey + ] ++ extras + + +monsters :: [Host] -- Systems I don't manage with propellor, +monsters = -- but do want to track their public keys etc. + [ host "usw-s002.rsync.net" $ props + & Ssh.hostPubKey SshEd25519 "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB7yTEBGfQYdwG/oeL+U9XPMIh/dW7XNs9T+M79YIOrd" + , host "github.com" $ props + & Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" + , host "gitlab.com" $ props + & 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" + ] + + + + -- o + -- ___ o o + {-----\ / o \ ___o o + { \ __ \ / _ (X___>-- __o + _____________________{ ______\___ \__/ | \__/ \____ |X__> + < \___//|\\___/\ \____________ _ + \ ___/ | \___ # # \ (-) + \ O O O # | \ # >=) + \______________________________# # / #__________________/ (-} + + diff --git a/propellor.cabal b/propellor.cabal @@ -0,0 +1,232 @@ +Name: propellor +Version: 3.2.3 +Cabal-Version: >= 1.8 +License: BSD2 +Maintainer: Joey Hess <id@joeyh.name> +Author: Joey Hess +Stability: Stable +Copyright: 2014 Joey Hess +License-File: LICENSE +Build-Type: Simple +Homepage: https://propellor.branchable.com/ +Category: Utility +Extra-Source-Files: + README.md + doc/README.mdwn + CHANGELOG + Makefile + config-simple.hs + config-freebsd.hs + joeyconfig.hs + config.hs + contrib/post-merge-hook + stack.yaml + debian/changelog + debian/propellor.README.Debian + debian/compat + debian/control + debian/copyright + debian/rules + debian/lintian-overrides +Synopsis: property-based host configuration management in haskell +Description: + 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. + . + It is configured using haskell. + +Executable propellor + 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 + 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, + unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, + time, mtl, transformers, exceptions (>= 0.6), stm, text + Other-Modules: + Propellor.DotDir + +Executable propellor-config + Main-Is: config.hs + GHC-Options: -threaded -Wall -fno-warn-tabs -O0 + if impl(ghc >= 8.0) + GHC-Options: -fno-warn-redundant-constraints + Extensions: TypeOperators + Hs-Source-Dirs: src + Build-Depends: + base >= 4.5, base < 5, + MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, + time, mtl, transformers, exceptions (>= 0.6), stm, text + +Library + GHC-Options: -Wall -fno-warn-tabs -O0 + if impl(ghc >= 8.0) + GHC-Options: -fno-warn-redundant-constraints + Extensions: TypeOperators + Hs-Source-Dirs: src + Build-Depends: + base >= 4.5, base < 5, + MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, + time, mtl, transformers, exceptions (>= 0.6), stm, text + + Exposed-Modules: + Propellor + Propellor.Base + Propellor.Location + Propellor.Property + Propellor.Property.Aiccu + Propellor.Property.Apache + Propellor.Property.Apt + Propellor.Property.Apt.PPA + Propellor.Property.Attic + Propellor.Property.Borg + Propellor.Property.Ccache + Propellor.Property.Cmd + Propellor.Property.Concurrent + Propellor.Property.Conductor + Propellor.Property.Hostname + Propellor.Property.Chroot + Propellor.Property.ConfFile + Propellor.Property.Cron + Propellor.Property.DebianMirror + Propellor.Property.Debootstrap + Propellor.Property.DiskImage + Propellor.Property.DiskImage.PartSpec + Propellor.Property.Dns + Propellor.Property.DnsSec + Propellor.Property.Docker + Propellor.Property.Fail2Ban + Propellor.Property.File + Propellor.Property.Firejail + Propellor.Property.Firewall + Propellor.Property.FreeBSD + Propellor.Property.FreeBSD.Pkg + Propellor.Property.FreeBSD.Poudriere + Propellor.Property.Fstab + Propellor.Property.Git + Propellor.Property.Gpg + Propellor.Property.Group + Propellor.Property.Grub + Propellor.Property.Journald + Propellor.Property.Kerberos + Propellor.Property.LetsEncrypt + Propellor.Property.List + Propellor.Property.LightDM + Propellor.Property.Locale + Propellor.Property.Logcheck + Propellor.Property.Mount + Propellor.Property.Network + Propellor.Property.Nginx + Propellor.Property.Obnam + Propellor.Property.OpenId + Propellor.Property.OS + Propellor.Property.Parted + Propellor.Property.Partition + Propellor.Property.Postfix + Propellor.Property.PropellorRepo + Propellor.Property.Prosody + Propellor.Property.Reboot + Propellor.Property.Rsync + Propellor.Property.Sbuild + Propellor.Property.Scheduled + Propellor.Property.Schroot + Propellor.Property.Service + Propellor.Property.Ssh + Propellor.Property.Sudo + Propellor.Property.Systemd + Propellor.Property.Systemd.Core + Propellor.Property.Tor + Propellor.Property.Unbound + Propellor.Property.User + Propellor.Property.Uwsgi + Propellor.Property.ZFS + Propellor.Property.ZFS.Process + Propellor.Property.ZFS.Properties + Propellor.Property.HostingProvider.CloudAtCost + Propellor.Property.HostingProvider.DigitalOcean + Propellor.Property.HostingProvider.Exoscale + Propellor.Property.HostingProvider.Linode + Propellor.Property.SiteSpecific.GitHome + Propellor.Property.SiteSpecific.JoeySites + Propellor.Property.SiteSpecific.GitAnnexBuilder + Propellor.Property.SiteSpecific.Branchable + Propellor.PropAccum + Propellor.Utilities + Propellor.CmdLine + Propellor.Container + Propellor.Info + Propellor.Message + Propellor.Debug + Propellor.PrivData + Propellor.Engine + Propellor.EnsureProperty + Propellor.Exception + Propellor.Types + Propellor.Types.Core + Propellor.Types.Chroot + Propellor.Types.CmdLine + Propellor.Types.Container + Propellor.Types.Docker + Propellor.Types.Dns + Propellor.Types.Empty + Propellor.Types.Exception + Propellor.Types.Info + Propellor.Types.MetaTypes + Propellor.Types.OS + Propellor.Types.PrivData + Propellor.Types.Result + Propellor.Types.ResultCheck + Propellor.Types.Singletons + Propellor.Types.ZFS + Other-Modules: + Propellor.Bootstrap + Propellor.Git + Propellor.Git.Config + Propellor.Git.VerifiedBranch + Propellor.Gpg + Propellor.Spin + Propellor.Ssh + Propellor.PrivData.Paths + Propellor.Protocol + Propellor.Shim + Propellor.Property.Chroot.Util + Utility.Applicative + Utility.Data + Utility.DataUnits + Utility.Directory + Utility.Env + Utility.Exception + Utility.FileMode + Utility.FileSystemEncoding + Utility.HumanNumber + Utility.LinuxMkLibs + Utility.Misc + Utility.Monad + Utility.Path + Utility.PartialPrelude + Utility.PosixFiles + Utility.Process + Utility.Process.Shim + Utility.Process.NonConcurrent + Utility.SafeCommand + Utility.Scheduled + Utility.SystemDirectory + Utility.Table + Utility.ThreadScheduler + Utility.Tmp + Utility.UserInfo + System.Console.Concurrent + System.Console.Concurrent.Internal + System.Process.Concurrent + +source-repository head + type: git + location: git://git.joeyh.name/propellor.git diff --git a/src/Propellor.hs b/src/Propellor.hs @@ -0,0 +1,76 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | When propellor runs on a Host, it ensures that its Properties +-- are satisfied, taking action as necessary when a Property is not +-- currently satisfied. +-- +-- A simple propellor program example: +-- +-- > import Propellor +-- > import qualified Propellor.Property.File as File +-- > import qualified Propellor.Property.Apt as Apt +-- > +-- > main :: IO () +-- > main = defaultMain hosts +-- > +-- > hosts :: [Host] +-- > hosts = [example] +-- > +-- > example :: Host +-- > example = host "example.com" $ props +-- > & Apt.installed ["mydaemon"] +-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1" +-- > `onChange` cmdProperty "service" ["mydaemon", "restart"] +-- > ! Apt.installed ["unwantedpackage"] +-- +-- See config.hs for a more complete example, and clone Propellor's +-- git repository for a deployable system using Propellor: +-- git clone <git://git.joeyh.name/propellor> + +module Propellor ( + -- * Core data types + Host(..) + , Property + , RevertableProperty + , module Propellor.Types + -- * Config file + , defaultMain + , host + , (&) + , (!) + -- * Propertries + -- | Properties are often combined together in your propellor + -- configuration. For example: + -- + -- > "/etc/foo/config" `File.containsLine` "bar=1" + -- > `requires` File.dirExists "/etc/foo" + , requires + , before + , onChange + , describe + , module Propellor.Property + -- | Everything you need to build your own properties, + -- and useful property combinators + , module Propellor.Property.Cmd + -- | Properties to run shell commands + , module Propellor.Info + -- | Properties that set `Info` + , module Propellor.Property.List + -- | Combining a list of properties into a single property + , module Propellor.Types.PrivData + -- | Private data access for properties + + , module X +) where + +import Propellor.Types +import Propellor.CmdLine (defaultMain) +import Propellor.Property +import Propellor.Property.List +import Propellor.Property.Cmd +import Propellor.Types.PrivData +import Propellor.Info +import Propellor.PropAccum + +import Data.Monoid as X +import Data.String as X (fromString) diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE PackageImports #-} + +-- | Pulls in lots of useful modules for building and using Properties. + +module Propellor.Base ( + -- * Propellor modules + module Propellor.Types + , module Propellor.Property + , module Propellor.Property.Cmd + , module Propellor.Property.List + , module Propellor.Types.PrivData + , module Propellor.PropAccum + , module Propellor.Info + , module Propellor.PrivData + , module Propellor.Engine + , module Propellor.Exception + , module Propellor.Message + , module Propellor.Debug + , module Propellor.Location + , module Propellor.Utilities + + -- * System modules + , module Utility.SystemDirectory + , module System.IO + , module System.FilePath + , module Data.Maybe + , module Data.Either + , module Control.Applicative + , module Control.Monad + , module Data.Monoid + , module Control.Monad.IfElse + , module Control.Monad.Reader +) where + +import Propellor.Types +import Propellor.Property +import Propellor.Engine +import Propellor.Property.List +import Propellor.Property.Cmd +import Propellor.PrivData +import Propellor.Types.PrivData +import Propellor.Message +import Propellor.Debug +import Propellor.Exception +import Propellor.Info +import Propellor.PropAccum +import Propellor.Location +import Propellor.Utilities + +import Utility.SystemDirectory +import System.IO +import System.FilePath +import Data.Maybe +import Data.Either +import Control.Applicative +import Control.Monad +import Data.Monoid +import Control.Monad.IfElse +import "mtl" Control.Monad.Reader diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs @@ -0,0 +1,229 @@ +module Propellor.Bootstrap ( + bootstrapPropellorCommand, + checkBinaryCommand, + installGitCommand, + buildPropellor, +) where + +import Propellor.Base +import Propellor.Types.Info +import Propellor.Git.Config + +import System.Posix.Files +import Data.List + +type ShellCommand = String + +-- 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 ++ + "&& if ! test -x ./propellor; then " + ++ buildCommand ++ + "; fi;" ++ checkBinaryCommand + +-- 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" + where + go = intercalate " && " + [ "cabal clean" + , buildCommand + ] + +buildCommand :: ShellCommand +buildCommand = intercalate " && " + [ "cabal configure" + , "cabal build propellor-config" + , "ln -sf dist/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" + +-- Install build dependencies of propellor. +-- +-- First, try to install ghc, cabal, gnupg, 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. +-- +-- Note: May succeed and leave some deps not installed. +depsCommand :: Maybe System -> ShellCommand +depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || 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 = + [ "cabal update" + , "cabal install --only-dependencies" + ] + + 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 + + -- This is the same deps listed in debian/control. + debdeps = + [ "gnupg" + , "ghc" + , "cabal-install" + , "libghc-async-dev" + , "libghc-missingh-dev" + , "libghc-hslogger-dev" + , "libghc-unix-compat-dev" + , "libghc-ansi-terminal-dev" + , "libghc-ifelse-dev" + , "libghc-network-dev" + , "libghc-mtl-dev" + , "libghc-transformers-dev" + , "libghc-exceptions-dev" + , "libghc-stm-dev" + , "libghc-text-dev" + , "make" + ] + fbsddeps = + [ "gnupg" + , "ghc" + , "hs-cabal-install" + , "hs-async" + , "hs-MissingH" + , "hs-hslogger" + , "hs-unix-compat" + , "hs-ansi-terminal" + , "hs-IfElse" + , "hs-network" + , "hs-mtl" + , "hs-transformers-base" + , "hs-exceptions" + , "hs-stm" + , "hs-text" + , "gmake" + ] + +installGitCommand :: Maybe System -> ShellCommand +installGitCommand msys = case msys of + (Just (System (Debian _ _) _)) -> use apt + (Just (System (Buntish _) _)) -> use apt + (Just (System (FreeBSD _) _)) -> use + [ "ASSUME_ALWAYS_YES=yes pkg update" + , "ASSUME_ALWAYS_YES=yes pkg install git" + ] + -- assume a debian derived system when not specified + Nothing -> use apt + where + use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi" + apt = + [ "apt-get update" + , "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" + ] + +buildPropellor :: Maybe Host -> IO () +buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $ + 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 + +-- 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. +-- +-- If the cabal configure fails, and a System is provided, installs +-- dependencies and retries. +cabalBuild :: Maybe System -> IO Bool +cabalBuild msys = do + make "dist/setup-config" ["propellor.cabal"] cabal_configure + unlessM cabal_build $ + unlessM (cabal_configure <&&> cabal_build) $ + error "cabal build failed" + -- For safety against eg power loss in the middle of the build, + -- make a copy of the binary, and move it into place atomically. + -- This ensures that the propellor symlink only ever points at + -- a binary that is fully built. Also, avoid ever removing + -- or breaking the symlink. + -- + -- Need cp -a to make build timestamp checking work. + unlessM (boolSystem "cp" [Param "-af", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $ + error "cp of binary failed" + rename (tmpfor safetycopy) safetycopy + symlinkPropellorBin safetycopy + return True + where + cabalbuiltbin = "dist/build/propellor-config/propellor-config" + safetycopy = cabalbuiltbin ++ ".built" + cabal_configure = ifM (cabal ["configure"]) + ( return True + , case msys of + Nothing -> return False + Just sys -> + boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))] + <&&> cabal ["configure"] + ) + cabal_build = cabal ["build", "propellor-config"] + +stackBuild :: Maybe System -> IO Bool +stackBuild _msys = do + createDirectoryIfMissing True builddest + ifM (stack buildparams) + ( do + symlinkPropellorBin (builddest </> "propellor-config") + return True + , return False + ) + where + builddest = ".built" + buildparams = + [ "--local-bin-path", builddest + , "build" + , ":propellor-config" -- only build config program + , "--copy-bins" + ] + +-- Atomic symlink creation/update. +symlinkPropellorBin :: FilePath -> IO () +symlinkPropellorBin bin = do + createSymbolicLink bin (tmpfor dest) + rename (tmpfor dest) dest + where + dest = "propellor" + +tmpfor :: FilePath -> FilePath +tmpfor f = f ++ ".propellortmp" + +make :: FilePath -> [FilePath] -> IO Bool -> IO () +make dest srcs builder = do + dt <- getmtime dest + st <- mapM getmtime srcs + when (dt == Nothing || any (> dt) st) $ + unlessM builder $ + error $ "failed to make " ++ dest + where + getmtime = catchMaybeIO . getModificationTime + +cabal :: [String] -> IO Bool +cabal = boolSystem "cabal" . map Param + +stack :: [String] -> IO Bool +stack = boolSystem "stack" . map Param diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs @@ -0,0 +1,212 @@ +module Propellor.CmdLine ( + defaultMain, + processCmdLine, +) where + +import System.Environment (getArgs) +import Data.List +import System.Exit +import System.PosixCompat +import Network.Socket + +import Propellor.Base +import Propellor.Gpg +import Propellor.Git +import Propellor.Git.VerifiedBranch +import Propellor.Bootstrap +import Propellor.Spin +import Propellor.Types.CmdLine +import qualified Propellor.Property.Docker as Docker +import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Shim as Shim + +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" + ] + +usageError :: [String] -> IO a +usageError ps = do + usage stderr + error ("(Unexpected: " ++ show ps) + +processCmdLine :: IO CmdLine +processCmdLine = go =<< getArgs + where + go ("--check":_) = return Check + go ("--spin":ps) = case reverse ps of + (r:"--via":hs) -> Spin + <$> mapM hostname (reverse hs) + <*> pure (Just r) + _ -> Spin <$> mapM hostname ps <*> pure Nothing + go ("--add-key":k:[]) = return $ AddKey k + go ("--rm-key":k:[]) = return $ RmKey k + go ("--set":f:c:[]) = withprivfield f c Set + go ("--unset":f:c:[]) = withprivfield f c Unset + go ("--unset-unused":[]) = return UnsetUnused + go ("--dump":f:c:[]) = withprivfield f c Dump + go ("--edit":f:c:[]) = withprivfield f c Edit + go ("--list-fields":[]) = return ListFields + go ("--merge":[]) = return Merge + go ("--help":_) = do + usage stdout + exitFailure + go ("--boot":_:[]) = return $ Update Nothing -- for back-compat + go ("--serialized":s:[]) = serialized Serialized s + go ("--continue":s:[]) = serialized Continue s + go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) + go ("--run":h:[]) = go [h] + go (h:[]) + | "--" `isPrefixOf` h = usageError [h] + | otherwise = Run <$> hostname h + go [] = do + s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] + if null s + then errorMessage "Cannot determine hostname! Pass it on the command line." + else return $ Run s + go v = usageError v + + withprivfield s c f = case readish s of + Just pf -> return $ f pf (Context c) + Nothing -> errorMessage $ "Unknown privdata field " ++ s + + serialized mk s = case readish s of + Just cmdline -> return $ mk cmdline + Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")" + +data CanRebuild = CanRebuild | NoRebuild + +-- | Runs propellor on hosts, as controlled by command-line options. +defaultMain :: [Host] -> IO () +defaultMain hostlist = withConcurrentOutput $ do + Shim.cleanEnv + checkDebugMode + cmdline <- processCmdLine + debug ["command line: ", show cmdline] + go CanRebuild cmdline + where + go cr (Serialized cmdline) = go cr cmdline + go _ Check = return () + go _ (Set field context) = setPrivData field context + go _ (Unset field context) = unsetPrivData field context + go _ (UnsetUnused) = unsetPrivDataUnused hostlist + go _ (Dump field context) = dumpPrivData field context + go _ (Edit field context) = editPrivData field context + go _ ListFields = listPrivDataFields hostlist + go _ (AddKey keyid) = addKey keyid + go _ (RmKey keyid) = rmKey keyid + go _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c + go _ (DockerChain hn cid) = Docker.chain hostlist hn cid + go _ (DockerInit hn) = Docker.init hn + go _ (GitPush fin fout) = gitPushHelper fin fout + go cr (Relay h) = forceConsole >> + updateFirst Nothing cr (Update (Just h)) (update (Just h)) + go _ (Update Nothing) = forceConsole >> + fetchFirst (onlyprocess (update Nothing)) + go _ (Update (Just h)) = update (Just h) + go _ Merge = mergeSpin + go cr cmdline@(Spin hs mrelay) = buildFirst Nothing cr cmdline $ do + unless (isJust mrelay) commitSpin + forM_ hs $ \hn -> withhost hn $ spin mrelay hn + go cr cmdline@(Run hn) = ifM ((==) 0 <$> getRealUserID) + ( updateFirst (findHost hostlist hn) cr cmdline $ runhost hn + , fetchFirst $ go cr (Spin [hn] Nothing) + ) + go cr cmdline@(SimpleRun hn) = forceConsole >> + fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn)) + -- When continuing after a rebuild, don't want to rebuild again. + go _ (Continue cmdline) = go NoRebuild cmdline + + withhost :: HostName -> (Host -> IO ()) -> IO () + withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) + + runhost hn = onlyprocess $ withhost hn mainProperties + + onlyprocess = onlyProcess (localdir </> ".lock") + +unknownhost :: HostName -> [Host] -> IO a +unknownhost h hosts = errorMessage $ unlines + [ "Propellor does not know about host: " ++ h + , "(Perhaps you should specify the real hostname on the command line?)" + , "(Or, edit propellor's config.hs to configure this host)" + , "Known hosts: " ++ unwords (map hostName hosts) + ] + +-- Builds propellor (when allowed) and if it looks like a new binary, +-- re-execs it to continue. +-- Otherwise, runs the IO action to continue. +-- +-- The Host should only be provided when dependencies should be installed +-- as needed to build propellor. +buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () +buildFirst h CanRebuild cmdline next = do + oldtime <- getmtime + buildPropellor h + newtime <- getmtime + if newtime == oldtime + then next + else continueAfterBuild cmdline + where + getmtime = catchMaybeIO $ getModificationTime "propellor" +buildFirst _ NoRebuild _ next = next + +continueAfterBuild :: CmdLine -> IO a +continueAfterBuild cmdline = go =<< boolSystem "./propellor" + [ Param "--continue" + , Param (show cmdline) + ] + where + go True = exitSuccess + go False = exitWith (ExitFailure 1) + +fetchFirst :: IO () -> IO () +fetchFirst next = do + whenM hasOrigin $ + void fetchOrigin + next + +updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () +updateFirst h canrebuild cmdline next = ifM hasOrigin + ( updateFirst' h canrebuild cmdline next + , next + ) + +-- 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 () +updateFirst' h CanRebuild cmdline next = ifM fetchOrigin + ( do + buildPropellor h + continueAfterBuild cmdline + , next + ) +updateFirst' _ NoRebuild _ next = next + +-- Gets the fully qualified domain name, given a string that might be +-- a short name to look up in the DNS. +hostname :: String -> IO HostName +hostname s = go =<< catchDefaultIO [] dnslookup + where + dnslookup = getAddrInfo (Just canonname) (Just s) Nothing + canonname = defaultHints { addrFlags = [AI_CANONNAME] } + go (AddrInfo { addrCanonName = Just v } : _) = pure v + go _ + | "." `isInfixOf` s = pure s -- assume it's a fqdn + | otherwise = + error $ "cannot find host " ++ s ++ " in the DNS" diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + +module Propellor.Container where + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.Types.Info +import Propellor.Info +import Propellor.PrivData +import Propellor.PropAccum + +class IsContainer c where + containerProperties :: c -> [ChildProperty] + containerInfo :: c -> Info + setContainerProperties :: c -> [ChildProperty] -> c + +instance IsContainer Host where + containerProperties = hostProperties + containerInfo = hostInfo + setContainerProperties h ps = host (hostName h) (Props ps) + +-- | Note that the metatype of a container's properties is not retained, +-- so this defaults to UnixLike. So, using this with setContainerProps can +-- add properties to a container that conflict with properties already in it. +-- Use caution when using this; only add properties that do not have +-- restricted targets. +containerProps :: IsContainer c => c -> Props UnixLike +containerProps = Props . containerProperties + +setContainerProps :: IsContainer c => c -> Props metatypes -> c +setContainerProps c (Props ps) = setContainerProperties c ps + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. +-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propagated out to the Property. +-- +-- Any PrivInfo that uses HostContext is adjusted to use the name +-- of the container as its context. +propagateContainer + :: + -- Since the children being added probably have info, + -- require the Property's metatypes to have info. + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + ( IncludesInfo metatypes ~ 'True + , IsContainer c + ) + => String + -> c + -> Property metatypes + -> Property metatypes +propagateContainer containername c prop = prop + `addChildren` map convert (containerProperties c) + where + convert p = + let n = property (getDesc p) (getSatisfy p) :: Property UnixLike + n' = n + `setInfoProperty` mapInfo (forceHostContext containername) + (propagatableInfo (getInfo p)) + `addChildren` map convert (getChildren p) + in toChildProperty n' diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs @@ -0,0 +1,37 @@ +module Propellor.Debug where + +import Control.Monad.IfElse +import System.IO +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple +import Control.Applicative +import Prelude + +import Utility.Monad +import Utility.Env +import Utility.Exception +import Utility.Process +import Utility.Directory + +debug :: [String] -> IO () +debug = debugM "propellor" . unwords + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just "1") = enableDebugMode + go (Just _) = noop + go Nothing = whenM (doesDirectoryExist ".git") $ + whenM (elem "1" . lines <$> getgitconfig) enableDebugMode + getgitconfig = catchDefaultIO "" $ + readProcess "git" ["config", "propellor.debug"] + +enableDebugMode :: IO () +enableDebugMode = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs @@ -0,0 +1,435 @@ +module Propellor.DotDir + ( distrepo + , dotPropellor + , interactiveInit + , checkRepoUpToDate + ) where + +import Propellor.Message +import Propellor.Bootstrap +import Propellor.Git +import Propellor.Gpg +import Propellor.Types.Result +import Utility.UserInfo +import Utility.Monad +import Utility.Process +import Utility.SafeCommand +import Utility.Exception +import Utility.Directory +import Utility.Path +-- This module is autogenerated by the build system. +import qualified Paths_propellor as Package + +import Data.Char +import Data.List +import Data.Version +import Control.Monad +import Control.Monad.IfElse +import System.FilePath +import System.Posix.Directory +import System.IO +import System.Console.Concurrent +import Control.Applicative +import Prelude + +distdir :: FilePath +distdir = "/usr/src/propellor" + +-- A distribution may include a bundle of propellor's git repository here. +-- If not, it will be pulled from the network when needed. +distrepo :: FilePath +distrepo = distdir </> "propellor.git" + +-- File containing the head rev of the distrepo. +disthead :: FilePath +disthead = distdir </> "head" + +upstreambranch :: String +upstreambranch = "upstream/master" + +-- Using the github mirror of the main propellor repo because +-- it is accessible over https for better security. +netrepo :: String +netrepo = "https://github.com/joeyh/propellor.git" + +dotPropellor :: IO FilePath +dotPropellor = do + home <- myHomeDir + return (home </> ".propellor") + +-- Detect if propellor was built using stack. This is somewhat of a hack. +buildSystem :: IO String +buildSystem = do + d <- Package.getLibDir + return $ if "stack-work" `isInfixOf` d then "stack" else "cabal" + +interactiveInit :: IO () +interactiveInit = ifM (doesDirectoryExist =<< dotPropellor) + ( error "~/.propellor/ already exists, not doing anything" + , do + welcomeBanner + setup + ) + +-- | Determine whether we need to create a cabal sandbox in ~/.propellor/, +-- which we do if the user has configured cabal to require a sandbox, and the +-- build system is cabal. +cabalSandboxRequired :: IO Bool +cabalSandboxRequired = ifM cabal + ( do + home <- myHomeDir + ls <- lines <$> catchDefaultIO [] + (readFile (home </> ".cabal" </> "config")) + -- For simplicity, we assume a sane ~/.cabal/config here: + return $ any ("True" `isInfixOf`) $ + filter ("require-sandbox:" `isPrefixOf`) ls + , return False + ) + where + cabal = buildSystem >>= \bSystem -> return (bSystem == "cabal") + +say :: String -> IO () +say = outputConcurrent + +sayLn :: String -> IO () +sayLn s = say (s ++ "\n") + +welcomeBanner :: IO () +welcomeBanner = say $ unlines $ map prettify + [ "" + , "" + , " _ ______`| ,-.__" + , " .--------------------------- / ~___-=O`/|O`/__| (____.'" + , " - Welcome to -- ~ / | / ) _.-'-._" + , " - Propellor! -- `/-==__ _/__|/__=-| ( ~_" + , " `--------------------------- * ~ | | '--------'" + , " (o) `" + , "" + , "" + ] + where + prettify = map (replace '~' '\\') + replace x y c + | c == x = y + | otherwise = c + +prompt :: String -> [(String, IO ())] -> IO () +prompt p cs = do + say (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ") + flushConcurrentOutput + hFlush stdout + r <- map toLower <$> getLine + if null r + then snd (head cs) -- default to first choice on return + else case filter (\(s, _) -> map toLower s == r) cs of + [(_, a)] -> a + _ -> do + sayLn "Not a valid choice, try again.. (Or ctrl-c to quit)" + prompt p cs + +section :: IO () +section = do + sayLn "" + sayLn "------------------------------------------------------------------------------" + sayLn "" + +setup :: IO () +setup = do + sayLn "Propellor's configuration file is ~/.propellor/config.hs" + sayLn "" + sayLn "Let's get you started with a simple config that you can adapt" + sayLn "to your needs. You can start with:" + sayLn " A: A clone of propellor's git repository (most flexible)" + sayLn " B: The bare minimum files to use propellor (most simple)" + prompt "Which would you prefer?" + [ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone) + , ("B", void $ actionMessage "Creating minimal config" minimalConfig) + ] + changeWorkingDirectory =<< dotPropellor + + section + sayLn "Let's try building the propellor configuration, to make sure it will work..." + sayLn "" + b <- buildSystem + void $ boolSystem "git" + [ Param "config" + , Param "propellor.buildsystem" + , Param b + ] + ifM cabalSandboxRequired + ( void $ boolSystem "cabal" + [ Param "sandbox" + , Param "init" + ] + , return () + ) + buildPropellor Nothing + sayLn "" + sayLn "Great! Propellor is bootstrapped." + + section + sayLn "Propellor can use gpg to encrypt private data about the systems it manages," + sayLn "and to sign git commits." + gpg <- getGpgBin + ifM (inPath gpg) + ( setupGpgKey + , do + sayLn "You don't seem to have gpg installed, so skipping setting it up." + explainManualSetupGpgKey + ) + + section + sayLn "Everything is set up ..." + sayLn "Your next step is to edit ~/.propellor/config.hs" + sayLn "and run propellor again to try it out." + sayLn "" + sayLn "For docs, see https://propellor.branchable.com/" + sayLn "Enjoy propellor!" + +explainManualSetupGpgKey :: IO () +explainManualSetupGpgKey = do + sayLn "Propellor can still be used without gpg, but it won't be able to" + sayLn "manage private data. You can set this up later:" + sayLn " 1. gpg --gen-key" + sayLn " 2. propellor --add-key (pass it the key ID generated in step 1)" + +setupGpgKey :: IO () +setupGpgKey = do + ks <- listSecretKeys + sayLn "" + case ks of + [] -> makeGpgKey + [(k, d)] -> do + sayLn $ "You have one gpg key: " ++ desckey k d + prompt "Should propellor use that key?" + [ ("Y", propellorAddKey k) + , ("N", sayLn $ "Skipping gpg setup. If you change your mind, run: propellor --add-key " ++ k) + ] + _ -> do + let nks = zip ks (map show ([1..] :: [Integer])) + sayLn "I see you have several gpg keys:" + forM_ nks $ \((k, d), n) -> + sayLn $ " " ++ n ++ " " ++ desckey k d + prompt "Which of your gpg keys should propellor use?" + (map (\((k, _), n) -> (n, propellorAddKey k)) nks) + where + desckey k d = d ++ " (keyid " ++ k ++ ")" + +makeGpgKey :: IO () +makeGpgKey = do + sayLn "You seem to not have any gpg secret keys." + prompt "Would you like to create one now?" + [("Y", rungpg), ("N", nope)] + where + nope = do + sayLn "No problem." + explainManualSetupGpgKey + rungpg = do + sayLn "Running gpg --gen-key ..." + gpg <- getGpgBin + void $ boolSystem gpg [Param "--gen-key"] + ks <- listSecretKeys + case ks of + [] -> do + sayLn "Hmm, gpg seemed to not set up a secret key." + prompt "Want to try running gpg again?" + [("Y", rungpg), ("N", nope)] + ((k, _):_) -> propellorAddKey k + +propellorAddKey :: String -> IO () +propellorAddKey keyid = do + sayLn "" + sayLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid + d <- dotPropellor + unlessM (boolSystem (d </> "propellor") [Param "--add-key", Param keyid]) $ do + sayLn "Oops, that didn't work! You can retry the same command later." + sayLn "Continuing onward ..." + +minimalConfig :: IO Result +minimalConfig = do + d <- dotPropellor + createDirectoryIfMissing True d + changeWorkingDirectory d + void $ boolSystem "git" [Param "init"] + addfile "config.cabal" cabalcontent + addfile "config.hs" configcontent + addfile "stack.yaml" stackcontent + return MadeChange + where + addfile f content = do + writeFile f (unlines content) + void $ boolSystem "git" [Param "add" , File f] + cabalcontent = + [ "-- This is a cabal file to use to build your propellor configuration." + , "" + , "Name: config" + , "Cabal-Version: >= 1.6" + , "Build-Type: Simple" + , "Version: 0" + , "" + , "Executable propellor-config" + , " Main-Is: config.hs" + , " GHC-Options: -threaded -Wall -fno-warn-tabs -O0" + , " Extensions: TypeOperators" + , " Build-Depends: propellor >= 3.0, base >= 3" + ] + configcontent = + [ "-- This is the main configuration file for Propellor, and is used to build" + , "-- the propellor program. https://propellor.branchable.com/" + , "" + , "import Propellor" + , "import qualified Propellor.Property.File as File" + , "import qualified Propellor.Property.Apt as Apt" + , "import qualified Propellor.Property.Cron as Cron" + , "import qualified Propellor.Property.User as User" + , "" + , "main :: IO ()" + , "main = defaultMain hosts" + , "" + , "-- The hosts propellor knows about." + , "hosts :: [Host]" + , "hosts =" + , " [ mybox" + , " ]" + , "" + , "-- An example host." + , "mybox :: Host" + , "mybox = host \"mybox.example.com\" $ props" + , " & osDebian Unstable X86_64" + , " & Apt.stdSourcesList" + , " & Apt.unattendedUpgrades" + , " & Apt.installed [\"etckeeper\"]" + , " & Apt.installed [\"ssh\"]" + , " & User.hasSomePassword (User \"root\")" + , " & File.dirExists \"/var/www\"" + , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" + , "" + ] + stackcontent = + -- This should be the same resolver version in propellor's + -- own stack.yaml + [ "resolver: " ++ stackResolver + , "packages:" + , "- '.'" + , "extra-deps:" + , "- propellor-" ++ showVersion Package.version + ] + +stackResolver :: String +stackResolver = "lts-5.10" + +fullClone :: IO Result +fullClone = do + d <- dotPropellor + let enterdotpropellor = changeWorkingDirectory d >> return True + ok <- ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) + ( allM id + [ boolSystem "git" [Param "clone", File distrepo, File d] + , fetchUpstreamBranch distrepo + , enterdotpropellor + , boolSystem "git" [Param "remote", Param "rm", Param "origin"] + ] + , allM id + [ boolSystem "git" [Param "clone", Param netrepo, File d] + , enterdotpropellor + -- Rename origin to upstream and avoid + -- git push to that read-only repo. + , boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"] + , boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] + ] + ) + return (toResult ok) + +fetchUpstreamBranch :: FilePath -> IO Bool +fetchUpstreamBranch repo = do + changeWorkingDirectory =<< dotPropellor + boolSystem "git" + [ Param "fetch" + , File repo + , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) + , Param "--quiet" + ] + +checkRepoUpToDate :: IO () +checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do + headrev <- takeWhile (/= '\n') <$> readFile disthead + changeWorkingDirectory =<< dotPropellor + headknown <- catchMaybeIO $ + withQuietOutput createProcessSuccess $ + proc "git" ["log", headrev] + if (headknown == Nothing) + then setupUpstreamMaster headrev + else do + theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef + when (theirhead /= headrev) $ do + merged <- not . null <$> + readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] + unless merged $ + warnoutofdate True + where + gitbundleavail = doesFileExist disthead + dotpropellorpopulated = do + d <- dotPropellor + doesFileExist (d </> "propellor.cabal") + +-- Makes upstream/master in dotPropellor be a usefully mergeable branch. +-- +-- We cannot just use origin/master, because in the case of a distrepo, +-- it only contains 1 commit. So, trying to merge with it will result +-- in lots of merge conflicts, since git cannot find a common parent +-- commit. +-- +-- Instead, the upstream/master branch is created by taking the +-- upstream/master branch (which must be an old version of propellor, +-- as distributed), and diffing from it to the current origin/master, +-- and committing the result. This is done in a temporary clone of the +-- repository, giving it a new master branch. That new branch is fetched +-- into the user's repository, as if fetching from a upstream remote, +-- yielding a new upstream/master branch. +setupUpstreamMaster :: String -> IO () +setupUpstreamMaster newref = do + changeWorkingDirectory =<< dotPropellor + go =<< catchMaybeIO getoldrev + where + go Nothing = warnoutofdate False + go (Just oldref) = do + let tmprepo = ".git/propellordisttmp" + let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo + cleantmprepo + git ["clone", "--quiet", ".", tmprepo] + + changeWorkingDirectory tmprepo + git ["fetch", distrepo, "--quiet"] + git ["reset", "--hard", oldref, "--quiet"] + v <- gitVersion + let mergeparams = + [ "merge", newref + , "-s", "recursive" + , "-Xtheirs" + , "--quiet" + , "-m", "merging upstream version" + ] ++ if v >= [2,9] + then [ "--allow-unrelated-histories" ] + else [] + git mergeparams + + void $ fetchUpstreamBranch tmprepo + cleantmprepo + warnoutofdate True + + getoldrev = takeWhile (/= '\n') + <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] + + git = run "git" + run cmd ps = unlessM (boolSystem cmd (map Param ps)) $ + error $ "Failed to run " ++ cmd ++ " " ++ show ps + +warnoutofdate :: Bool -> IO () +warnoutofdate havebranch = do + warningMessage ("** Your ~/.propellor/ is out of date..") + let also s = hPutStrLn stderr (" " ++ s) + also ("A newer upstream version is available in " ++ distrepo) + if havebranch + then also ("To merge it, run: git merge " ++ upstreambranch) + else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.") + also "" diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE DataKinds #-} + +module Propellor.Engine ( + mainProperties, + runPropellor, + ensureChildProperties, + fromHost, + fromHost', + onlyProcess, +) where + +import System.Exit +import System.IO +import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import System.PosixCompat +import System.Posix.IO +import System.FilePath +import Control.Applicative +import Prelude + +import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core +import Propellor.Message +import Propellor.Exception +import Propellor.Info +import Utility.Exception +import Utility.Directory + +-- | Gets the Properties of a Host, and ensures them all, +-- with nice display of what's being done. +mainProperties :: Host -> IO () +mainProperties host = do + ret <- runPropellor host $ ensureChildProperties [toChildProperty overall] + messagesDone + case ret of + FailedChange -> exitWith (ExitFailure 1) + _ -> exitWith ExitSuccess + where + overall :: Property (MetaTypes '[]) + overall = property "overall" $ + ensureChildProperties (hostProperties host) + +-- | Runs a Propellor action with the specified host. +-- +-- If the Result is not FailedChange, any EndActions +-- that were accumulated while running the action +-- are then also run. +runPropellor :: Host -> Propellor Result -> IO Result +runPropellor host a = do + (res, endactions) <- evalRWST (runWithHost a) host () + endres <- mapM (runEndAction host res) endactions + return $ mconcat (res:endres) + +runEndAction :: Host -> Result -> EndAction -> IO Result +runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc $ do + (ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host () + return ret + +-- | Ensures the child properties, with a display of each as it runs. +ensureChildProperties :: [ChildProperty] -> Propellor Result +ensureChildProperties ps = ensure ps NoChange + where + ensure [] rs = return rs + ensure (p:ls) rs = do + hn <- asks hostName + r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p) + ensure ls (r <> rs) + +-- | Lifts an action into the context of a different host. +-- +-- > fromHost hosts "otherhost" Ssh.getHostPubKey +fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) +fromHost l hn getter = case findHost l hn of + Nothing -> return Nothing + Just h -> Just <$> fromHost' h getter + +fromHost' :: Host -> Propellor a -> Propellor a +fromHost' h getter = do + (ret, _s, runlog) <- liftIO $ runRWST (runWithHost getter) h () + tell runlog + return ret + +onlyProcess :: FilePath -> IO a -> IO a +onlyProcess lockfile a = bracket lock unlock (const a) + where + lock = do + createDirectoryIfMissing True (takeDirectory lockfile) + l <- createFile lockfile stdFileMode + setLock l (WriteLock, AbsoluteSeek, 0, 0) + `catchIO` const alreadyrunning + return l + unlock = closeFd + alreadyrunning = error "Propellor is already running on this host!" diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Propellor.EnsureProperty + ( ensureProperty + , property' + , OuterMetaTypesWitness(..) + ) where + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.Exception + +import Data.Monoid +import Prelude + +-- | For when code running in the Propellor monad needs to ensure a +-- Property. +-- +-- Use `property'` to get the `OuterMetaTypesWithness`. For example: +-- +-- > foo = Property Debian +-- > foo = property' "my property" $ \w -> do +-- > ensureProperty w (aptInstall "foo") +-- +-- The type checker will prevent using ensureProperty with a property +-- that does not support the target OSes needed by the OuterMetaTypesWitness. +-- In the example above, aptInstall must support Debian, since foo +-- is supposed to support Debian. +-- +-- The type checker will also prevent using ensureProperty with a property +-- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated +-- with the property to be lost. +ensureProperty + :: + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + ( Cannot_ensureProperty_WithInfo inner ~ 'True + , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine + ) + => OuterMetaTypesWitness outer + -> Property (MetaTypes inner) + -> Propellor Result +ensureProperty _ = catchPropellor . getSatisfy + +-- The name of this was chosen to make type errors a bit more understandable. +type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool +type instance Cannot_ensureProperty_WithInfo '[] = 'True +type instance Cannot_ensureProperty_WithInfo (t ': ts) = + Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts + +-- | Constructs a property, like `property`, but provides its +-- `OuterMetaTypesWitness`. +property' + :: SingI metatypes + => Desc + -> (OuterMetaTypesWitness metatypes -> Propellor Result) + -> Property (MetaTypes metatypes) +property' d a = + let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty + in p + +-- | Used to provide the metatypes of a Property to calls to +-- 'ensureProperty` within it. +newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes) + +outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l +outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +module Propellor.Exception where + +import Propellor.Types +import Propellor.Types.Exception +import Propellor.Message +import Utility.Exception + +import Control.Exception (AsyncException) +#if MIN_VERSION_base(4,7,0) +import Control.Exception (SomeAsyncException) +#endif +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO) +import Prelude + +-- | Catches all exceptions (except for `StopPropellorException` and +-- `AsyncException` and `SomeAsyncException`) and returns FailedChange. +catchPropellor :: (MonadIO m, MonadCatch m) => m Result -> m Result +catchPropellor a = either err return =<< tryPropellor a + where + err e = warningMessage (show e) >> return FailedChange + +catchPropellor' :: MonadCatch m => m a -> (SomeException -> m a) -> m a +catchPropellor' a onerr = a `catches` + [ Handler (\ (e :: AsyncException) -> throwM e) +#if MIN_VERSION_base(4,7,0) + , Handler (\ (e :: SomeAsyncException) -> throwM e) +#endif + , Handler (\ (e :: StopPropellorException) -> throwM e) + , Handler (\ (e :: SomeException) -> onerr e) + ] + +-- | Catches all exceptions (except for `StopPropellorException` and +-- `AsyncException`). +tryPropellor :: MonadCatch m => m a -> m (Either SomeException a) +tryPropellor a = (return . Right =<< a) `catchPropellor'` (return . Left) diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs @@ -0,0 +1,41 @@ +module Propellor.Git where + +import Utility.Process +import Utility.Exception +import Utility.Directory +import Utility.Misc +import Utility.PartialPrelude + +import Data.Maybe +import Control.Applicative +import Prelude + +getCurrentBranch :: IO String +getCurrentBranch = takeWhile (/= '\n') + <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] + +getCurrentBranchRef :: IO String +getCurrentBranchRef = takeWhile (/= '\n') + <$> readProcess "git" ["symbolic-ref", "HEAD"] + +getCurrentGitSha1 :: String -> IO String +getCurrentGitSha1 branchref = takeWhile (/= '\n') + <$> readProcess "git" ["show-ref", "--hash", branchref] + +hasOrigin :: IO Bool +hasOrigin = catchDefaultIO False $ do + rs <- lines <$> readProcess "git" ["remote"] + return $ "origin" `elem` rs + +hasGitRepo :: IO Bool +hasGitRepo = doesFileExist ".git/HEAD" + +type Version = [Int] + +gitVersion :: IO Version +gitVersion = extract <$> readProcess "git" ["--version"] + where + extract s = case lines s of + [] -> [] + (l:_) -> mapMaybe readish $ segment (== '.') $ + unwords $ drop 2 $ words l diff --git a/src/Propellor/Git/Config.hs b/src/Propellor/Git/Config.hs @@ -0,0 +1,49 @@ +module Propellor.Git.Config where + +import Propellor.Git +import Utility.Process +import Utility.Exception +import Utility.SafeCommand +import Utility.Monad + +import Control.Monad +import Control.Applicative +import Prelude + +getGitConfigValue :: String -> IO (Maybe String) +getGitConfigValue key = do + value <- catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess"git" ["config", key] + return $ case value of + Just v | not (null v) -> Just v + _ -> Nothing + +-- `git config --bool propellor.blah` outputs "false" if propellor.blah is unset +-- i.e. the git convention is that the default value of any git-config setting +-- is "false". So we don't need a Maybe Bool here. +getGitConfigBool :: String -> IO Bool +getGitConfigBool key = do + value <- catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess "git" ["config", "--bool", key] + return $ case value of + Just "true" -> True + _ -> False + +setRepoUrl :: String -> IO () +setRepoUrl "" = return () +setRepoUrl url = do + subcmd <- ifM hasOrigin (pure "set-url", pure "add") + void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url] + -- same as --set-upstream-to, except origin branch + -- may not have been pulled yet + branch <- getCurrentBranch + let branchval s = "branch." ++ branch ++ "." ++ s + void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"] + void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch] + +getRepoUrl :: IO (Maybe String) +getRepoUrl = getM getGitConfigValue urls + where + urls = ["remote.deploy.url", "remote.origin.url"] diff --git a/src/Propellor/Git/VerifiedBranch.hs b/src/Propellor/Git/VerifiedBranch.hs @@ -0,0 +1,52 @@ +module Propellor.Git.VerifiedBranch where + +import Propellor.Base +import Propellor.Git +import Propellor.PrivData.Paths +import Utility.FileMode + +{- To verify origin branch commit's signature, have to convince gpg + - to use our keyring. + - While running git log. Which has no way to pass options to gpg. + - Argh! + -} +verifyOriginBranch :: String -> IO Bool +verifyOriginBranch originbranch = do + let gpgconf = privDataDir </> "gpg.conf" + keyring <- privDataKeyring + writeFile gpgconf $ unlines + [ " keyring " ++ keyring + , "no-auto-check-trustdb" + ] + -- gpg is picky about perms + modifyFileMode privDataDir (removeModes otherGroupModes) + s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch] + (Just [("GNUPGHOME", privDataDir)]) + nukeFile $ privDataDir </> "trustdb.gpg" + nukeFile $ privDataDir </> "pubring.gpg" + nukeFile $ privDataDir </> "gpg.conf" + return (s == "U\n" || s == "G\n") + +-- Returns True if HEAD is changed by fetching and merging from origin. +fetchOrigin :: IO Bool +fetchOrigin = do + branchref <- getCurrentBranch + let originbranch = "origin" </> branchref + + void $ actionMessage "Pull from central git repository" $ + boolSystem "git" [Param "fetch"] + + oldsha <- getCurrentGitSha1 branchref + + keyring <- privDataKeyring + whenM (doesFileExist keyring) $ + ifM (verifyOriginBranch originbranch) + ( do + putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging" + hFlush stdout + void $ boolSystem "git" [Param "merge", Param originbranch] + , warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)" + ) + + newsha <- getCurrentGitSha1 branchref + return $ oldsha /= newsha diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs @@ -0,0 +1,206 @@ +module Propellor.Gpg where + +import System.IO +import Data.Maybe +import Data.List.Utils +import Control.Monad +import Control.Applicative +import Prelude + +import Propellor.PrivData.Paths +import Propellor.Message +import Propellor.Git.Config +import Utility.SafeCommand +import Utility.Process +import Utility.Process.NonConcurrent +import Utility.Monad +import Utility.Misc +import Utility.Tmp +import Utility.FileSystemEncoding +import Utility.Env +import Utility.Directory + +type KeyId = String + +getGpgBin :: IO String +getGpgBin = do + gitGpgBin <- getGitConfigValue "gpg.program" + case gitGpgBin of + Nothing -> getEnvDefault "GNUPGBIN" "gpg" + Just b -> return b + +-- Lists the keys in propellor's keyring. +listPubKeys :: IO [KeyId] +listPubKeys = do + keyring <- privDataKeyring + let listopts = + [ "--list-public-keys" + , "--with-colons" + , "--fixed-list-mode" + ] ++ useKeyringOpts keyring + gpgbin <- getGpgBin + parse . lines <$> readProcess gpgbin listopts + where + parse = mapMaybe (extract . split ":") + extract ("pub":_:_:_:f:_) = Just f + extract _ = Nothing + +-- Lists all of the user's secret keys. +listSecretKeys :: IO [(KeyId, String)] +listSecretKeys = do + gpgbin <- getGpgBin + parse . lines <$> readProcess gpgbin + [ "--list-secret-keys" + , "--with-colons" + , "--fixed-list-mode" + ] + where + parse = extract [] Nothing . map (split ":") + extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) = + extract ((keyid, userid):c) Nothing rest + extract c (Just keyid) rest@(("sec":_):_) = + extract ((keyid, ""):c) Nothing rest + extract c (Just keyid) rest@(("pub":_):_) = + extract ((keyid, ""):c) Nothing rest + extract c (Just keyid) (_:rest) = + extract c (Just keyid) rest + extract c _ [] = c + extract c _ (("sec":_:_:_:keyid:_):rest) = + extract c (Just keyid) rest + extract c k (_:rest) = + extract c k rest + +useKeyringOpts :: FilePath -> [String] +useKeyringOpts keyring = + [ "--options" + , "/dev/null" + , "--no-default-keyring" + , "--keyring", keyring + ] + +addKey :: KeyId -> IO () +addKey keyid = do + gpgbin <- getGpgBin + keyring <- privDataKeyring + exitBool =<< allM (uncurry actionMessage) + [ ("adding key to propellor's keyring", addkeyring keyring gpgbin) + , ("staging propellor's keyring", gitAdd keyring) + , ("updating encryption of any privdata", reencryptPrivData) + , ("configuring git commit signing to use key", gitconfig gpgbin) + , ("committing changes", gitCommitKeyRing "add-key") + ] + where + addkeyring keyring' gpgbin' = do + createDirectoryIfMissing True privDataDir + boolSystem "sh" + [ Param "-c" + , Param $ gpgbin' ++ " --export " ++ keyid ++ " | gpg " ++ + unwords (useKeyringOpts keyring' ++ ["--import"]) + ] + + gitconfig gpgbin' = ifM (snd <$> processTranscript gpgbin' ["--list-secret-keys", keyid] Nothing) + ( boolSystem "git" + [ Param "config" + , Param "user.signingkey" + , Param keyid + ] + , do + warningMessage $ "Cannot find a secret key for key " ++ keyid ++ ", so not configuring git user.signingkey to use this key." + return True + ) + +rmKey :: KeyId -> IO () +rmKey keyid = do + gpgbin <- getGpgBin + keyring <- privDataKeyring + exitBool =<< allM (uncurry actionMessage) + [ ("removing key from propellor's keyring", rmkeyring keyring gpgbin) + , ("staging propellor's keyring", gitAdd keyring) + , ("updating encryption of any privdata", reencryptPrivData) + , ("configuring git commit signing to not use key", gitconfig) + , ("committing changes", gitCommitKeyRing "rm-key") + ] + where + rmkeyring keyring' gpgbin' = boolSystem gpgbin' $ + (map Param (useKeyringOpts keyring')) ++ + [ Param "--batch" + , Param "--yes" + , Param "--delete-key", Param keyid + ] + + gitconfig = ifM ((==) (keyid++"\n", True) <$> processTranscript "git" ["config", "user.signingkey"] Nothing) + ( boolSystem "git" + [ Param "config" + , Param "--unset" + , Param "user.signingkey" + ] + , return True + ) + +reencryptPrivData :: IO Bool +reencryptPrivData = do + f <- privDataFile + ifM (doesFileExist f) + ( do + gpgEncrypt f =<< gpgDecrypt f + gitAdd f + , return True + ) + +gitAdd :: FilePath -> IO Bool +gitAdd f = boolSystem "git" + [ Param "add" + , File f + ] + +gitCommitKeyRing :: String -> IO Bool +gitCommitKeyRing action = do + keyring <- privDataKeyring + privdata <- privDataFile + -- Commit explicitly the keyring and privdata files, as other + -- changes may be staged by the user and shouldn't be committed. + tocommit <- filterM doesFileExist [ privdata, keyring] + gitCommit (Just ("propellor " ++ action)) (map File tocommit) + +-- Adds --gpg-sign if there's a keyring. +gpgSignParams :: [CommandParam] -> IO [CommandParam] +gpgSignParams ps = do + keyring <- privDataKeyring + ifM (doesFileExist keyring) + ( return (ps ++ [Param "--gpg-sign"]) + , return ps + ) + +-- Automatically sign the commit if there'a a keyring. +gitCommit :: Maybe String -> [CommandParam] -> IO Bool +gitCommit msg ps = do + let ps' = Param "commit" : ps ++ + maybe [] (\m -> [Param "-m", Param m]) msg + ps'' <- gpgSignParams ps' + boolSystemNonConcurrent "git" ps'' + +gpgDecrypt :: FilePath -> IO String +gpgDecrypt f = do + gpgbin <- getGpgBin + ifM (doesFileExist f) + ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing (Just fileEncoding) + , return "" + ) + +-- Encrypt file to all keys in propellor's keyring. +gpgEncrypt :: FilePath -> String -> IO () +gpgEncrypt f s = do + gpgbin <- getGpgBin + keyids <- listPubKeys + let opts = + [ "--default-recipient-self" + , "--armor" + , "--encrypt" + , "--trust-model", "always" + ] ++ concatMap (\k -> ["--recipient", k]) keyids + encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing + viaTmp writeFile f encrypted + where + writer h = do + fileEncoding h + hPutStr h s diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} + +module Propellor.Info ( + osDebian, + osBuntish, + osFreeBSD, + setInfoProperty, + addInfoProperty, + pureInfoProperty, + pureInfoProperty', + askInfo, + getOS, + ipv4, + ipv6, + alias, + addDNS, + hostMap, + aliasMap, + findHost, + findHostNoAlias, + getAddresses, + hostAddresses, +) where + +import Propellor.Types +import Propellor.Types.Info +import Propellor.Types.MetaTypes + +import "mtl" Control.Monad.Reader +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Control.Applicative +import Prelude + +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +setInfoProperty + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (MetaTypes metatypes') +setInfoProperty (Property _ d a oldi c) newi = + Property sing d a (oldi <> newi) c + +-- | Adds more info to a Property that already HasInfo. +addInfoProperty + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + :: (IncludesInfo metatypes ~ 'True) + => Property metatypes + -> Info + -> Property metatypes +addInfoProperty (Property t d a oldi c) newi = + Property t d a (oldi <> newi) c + +-- | Makes a property that does nothing but set some `Info`. +pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike) +pureInfoProperty desc v = pureInfoProperty' desc (toInfo v) + +pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike) +pureInfoProperty' desc i = setInfoProperty p i + where + p :: Property UnixLike + p = property ("has " ++ desc) (return NoChange) + +-- | Gets a value from the host's Info. +askInfo :: (IsInfo v) => Propellor v +askInfo = asks (fromInfo . hostInfo) + +-- | Specifies that a host's operating system is Debian, +-- and further indicates the suite and architecture. +-- +-- This provides info for other Properties, so they can act +-- conditionally on the details of the OS. +-- +-- It also lets the type checker know that all the properties of the +-- host must support Debian. +-- +-- > & osDebian (Stable "jessie") 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' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian) +osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch) + +-- | Specifies that a host's operating system is 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/>) +osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish) +osBuntish release arch = tightenTargets $ os (System (Buntish release) arch) + +-- | Specifies that a host's operating system is FreeBSD +-- and further indicates the release and architecture. +osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) +osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch) + +os :: System -> Property (HasInfo + UnixLike) +os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system) + +-- Gets the operating system of a host, if it has been specified. +getOS :: Propellor (Maybe System) +getOS = fromInfoVal <$> askInfo + +-- | Indicate that a host has an A record in the DNS. +-- +-- When propellor is used to deploy a DNS server for a domain, +-- the hosts in the domain are found by looking for these +-- and similar properites. +-- +-- When propellor --spin is used to deploy a host, it checks +-- if the host's IP Property matches the DNS. If the DNS is missing or +-- out of date, the host will instead be contacted directly by IP address. +ipv4 :: String -> Property (HasInfo + UnixLike) +ipv4 = addDNS . Address . IPv4 + +-- | Indicate that a host has an AAAA record in the DNS. +ipv6 :: String -> Property (HasInfo + UnixLike) +ipv6 = addDNS . Address . IPv6 + +-- | Indicates another name for the host in the DNS. +-- +-- When the host's ipv4/ipv6 addresses are known, the alias is set up +-- to use their address, rather than using a CNAME. This avoids various +-- problems with CNAMEs, and also means that when multiple hosts have the +-- same alias, a DNS round-robin is automatically set up. +alias :: Domain -> Property (HasInfo + UnixLike) +alias d = pureInfoProperty' ("alias " ++ d) $ mempty + `addInfo` toAliasesInfo [d] + -- A CNAME is added here, but the DNS setup code converts it to an + -- IP address when that makes sense. + `addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d) + +addDNS :: Record -> Property (HasInfo + UnixLike) +addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r)) + where + rdesc (CNAME d) = unwords ["alias", ddesc d] + rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] + rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr] + rdesc (MX n d) = unwords ["MX", show n, ddesc d] + rdesc (NS d) = unwords ["NS", ddesc d] + rdesc (TXT s) = unwords ["TXT", s] + rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] + rdesc (SSHFP x y s) = unwords ["SSHFP", show x, show y, s] + rdesc (INCLUDE f) = unwords ["$INCLUDE", f] + rdesc (PTR x) = unwords ["PTR", x] + + ddesc (AbsDomain domain) = domain + ddesc (RelDomain domain) = domain + ddesc RootDomain = "@" + +hostMap :: [Host] -> M.Map HostName Host +hostMap l = M.fromList $ zip (map hostName l) l + +aliasMap :: [Host] -> M.Map HostName Host +aliasMap = M.fromList . concat . + map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h) + +findHost :: [Host] -> HostName -> Maybe Host +findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn) + +findHostNoAlias :: [Host] -> HostName -> Maybe Host +findHostNoAlias l hn = M.lookup hn (hostMap l) + +findAlias :: [Host] -> HostName -> Maybe Host +findAlias l hn = M.lookup hn (aliasMap l) + +getAddresses :: Info -> [IPAddr] +getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo + +hostAddresses :: HostName -> [Host] -> [IPAddr] +hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) diff --git a/src/Propellor/Location.hs b/src/Propellor/Location.hs @@ -0,0 +1,5 @@ +module Propellor.Location where + +-- | This is where propellor installs itself when deploying a host. +localdir :: FilePath +localdir = "/usr/local/propellor" diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs @@ -0,0 +1,169 @@ +-- | This module handles all display of output to the console when +-- propellor is ensuring Properties. +-- +-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. + +module Propellor.Message ( + getMessageHandle, + isConsole, + forceConsole, + actionMessage, + actionMessageOn, + warningMessage, + infoMessage, + errorMessage, + stopPropellorMessage, + processChainOutput, + messagesDone, + createProcessConcurrent, + withConcurrentOutput, +) where + +import System.Console.ANSI +import System.IO +import Control.Monad.IO.Class (liftIO, MonadIO) +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import System.Console.Concurrent +import Control.Applicative +import Prelude + +import Propellor.Types +import Propellor.Types.Exception +import Utility.PartialPrelude +import Utility.Monad +import Utility.Exception + +data MessageHandle = MessageHandle + { isConsole :: Bool + } + +-- | A shared global variable for the MessageHandle. +{-# NOINLINE globalMessageHandle #-} +globalMessageHandle :: MVar MessageHandle +globalMessageHandle = unsafePerformIO $ + newMVar =<< MessageHandle + <$> catchDefaultIO False (hIsTerminalDevice stdout) + +-- | Gets the global MessageHandle. +getMessageHandle :: IO MessageHandle +getMessageHandle = readMVar globalMessageHandle + +-- | 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. +forceConsole :: IO () +forceConsole = modifyMVar_ globalMessageHandle $ \mh -> + pure (mh { isConsole = True }) + +whenConsole :: String -> IO String +whenConsole s = ifM (isConsole <$> getMessageHandle) + ( pure s + , pure "" + ) + +-- | 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 = 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 = actionMessage' . Just + +actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' mhn desc a = do + liftIO $ outputConcurrent + =<< whenConsole (setTitleCode $ "propellor: " ++ desc) + + r <- a + + liftIO $ outputConcurrent . concat =<< sequence + [ whenConsole $ + setTitleCode "propellor: running" + , showhn mhn + , pure $ desc ++ " ... " + , let (msg, intensity, color) = getActionResult r + in colorLine intensity color msg + ] + + return r + where + showhn Nothing = return "" + showhn (Just hn) = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground Dull Cyan] + , pure (hn ++ " ") + , whenConsole $ + setSGRCode [] + ] + +warningMessage :: MonadIO m => String -> m () +warningMessage s = liftIO $ + outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) + +infoMessage :: MonadIO m => [String] -> m () +infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls + +-- | Displays the error message in red, and throws an exception. +-- +-- When used inside a property, the exception will make the current +-- 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) + -- 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. + error "Cannot continue!" + +-- | Like `errorMessage`, but throws a `StopPropellorException`, +-- preventing propellor from continuing to the next property. +-- +-- Think twice before using this. Is the problem so bad that propellor +-- cannot try to ensure other properties? If not, use `errorMessage` +-- instead. +stopPropellorMessage :: MonadIO m => String -> m a +stopPropellorMessage s = liftIO $ do + outputConcurrent =<< colorLine Vivid Red ("** fatal error: " ++ s) + throwM $ StopPropellorException "Cannot continue!" + +colorLine :: ColorIntensity -> Color -> String -> IO String +colorLine intensity color msg = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground intensity color] + , pure msg + , whenConsole $ + setSGRCode [] + -- Note this comes after the color is reset, so that + -- the color set and reset happen in the same line. + , 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 + =<< whenConsole (setTitleCode "propellor: done") diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module Propellor.PrivData ( + withPrivData, + withSomePrivData, + addPrivData, + setPrivData, + unsetPrivData, + unsetPrivDataUnused, + dumpPrivData, + editPrivData, + filterPrivData, + listPrivDataFields, + makePrivDataDir, + decryptPrivData, + readPrivData, + readPrivDataFile, + PrivMap, + PrivInfo, + forceHostContext, +) where + +import System.IO +import Data.Maybe +import Data.List +import Data.Typeable +import Control.Monad +import Control.Monad.IfElse +import "mtl" Control.Monad.Reader +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.ByteString.Lazy as L +import Control.Applicative +import Data.Monoid +import Prelude + +import Propellor.Types +import Propellor.Types.PrivData +import Propellor.Types.MetaTypes +import Propellor.Types.Info +import Propellor.Message +import Propellor.Info +import Propellor.Gpg +import Propellor.PrivData.Paths +import Utility.Monad +import Utility.PartialPrelude +import Utility.Exception +import Utility.Tmp +import Utility.SafeCommand +import Utility.Process.NonConcurrent +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, +-- for use in a specific Context or HostContext. +-- +-- Example use: +-- +-- > withPrivData (PrivFile pemfile) (Context "joeyh.name") $ \getdata -> +-- > property "joeyh.name ssl cert" $ getdata $ \privdata -> +-- > liftIO $ writeFile pemfile (privDataVal privdata) +-- > where pemfile = "/etc/ssl/certs/web.pem" +-- +-- Note that if the value is not available, the action is not run +-- and instead it prints a message to help the user make the necessary +-- private data available. +-- +-- The resulting Property includes Info about the PrivDataField +-- being used, which is necessary to ensure that the privdata is sent to +-- the remote host by propellor. +withPrivData + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) + => s + -> c + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes +withPrivData s = withPrivData' snd [s] + +-- Like withPrivData, but here any one of a list of PrivDataFields can be used. +withSomePrivData + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) + => [s] + -> c + -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes +withSomePrivData = withPrivData' id + +withPrivData' + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) + => ((PrivDataField, PrivData) -> v) + -> [s] + -> c + -> (((v -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes +withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> + maybe missing (a . feed) =<< getM get fieldlist + where + get field = do + context <- mkHostContext hc <$> asks hostName + maybe Nothing (\privdata -> Just (field, privdata)) + <$> liftIO (getLocalPrivData field context) + missing = do + Context cname <- mkHostContext hc <$> asks hostName + warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" + infoMessage $ + "Fix this by running:" : + showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) + return FailedChange + addinfo p = p `addInfoProperty` (toInfo privset) + privset = PrivInfo $ S.fromList $ + map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist + fieldnames = map show fieldlist + fieldlist = map privDataField srclist + hc = asHostContext c + +showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> [String] +showSet = concatMap go + where + go (f, Context c, md) = catMaybes + [ Just $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" + , maybe Nothing (\d -> Just $ " " ++ d) md + , Just "" + ] + +addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property (HasInfo + UnixLike) +addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v)) + +{- Gets the requested field's value, in the specified context if it's + - available, from the host's local privdata cache. -} +getLocalPrivData :: PrivDataField -> Context -> IO (Maybe PrivData) +getLocalPrivData field context = + getPrivData field context . fromMaybe M.empty <$> localcache + where + localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal + +type PrivMap = M.Map (PrivDataField, Context) String + +-- | Get only the set of PrivData that the Host's Info says it uses. +filterPrivData :: Host -> PrivMap -> PrivMap +filterPrivData host = M.filterWithKey (\k _v -> S.member k used) + where + used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $ + fromPrivInfo $ fromInfo $ hostInfo host + +getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData +getPrivData field context m = do + s <- M.lookup (field, context) m + return (PrivData s) + +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 () +unsetPrivData field context = do + modifyPrivData $ M.delete (field, context) + descUnset field context + +descUnset :: PrivDataField -> Context -> IO () +descUnset field context = + putStrLn $ "Private data unset: " ++ show field ++ " " ++ show context + +unsetPrivDataUnused :: [Host] -> IO () +unsetPrivDataUnused hosts = do + deleted <- modifyPrivData' $ \m -> + let (keep, del) = M.partitionWithKey (\k _ -> k `M.member` usedby) m + in (keep, M.keys del) + mapM_ (uncurry descUnset) deleted + where + usedby = mkUsedByMap hosts + +dumpPrivData :: PrivDataField -> Context -> IO () +dumpPrivData field context = do + maybe (error "Requested privdata is not set.") + (L.hPut stdout . privDataByteString) + =<< (getPrivData field context <$> decryptPrivData) + +editPrivData :: PrivDataField -> Context -> IO () +editPrivData field context = do + v <- getPrivData field context <$> decryptPrivData + v' <- withTmpFile "propellorXXXX" $ \f th -> do + hClose th + maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v + editor <- getEnvDefault "EDITOR" "vi" + unlessM (boolSystemNonConcurrent editor [File f]) $ + error "Editor failed; aborting." + PrivData <$> readFile f + setPrivDataTo field context v' + +listPrivDataFields :: [Host] -> IO () +listPrivDataFields hosts = do + m <- decryptPrivData + + section "Currently set data:" + showtable $ map mkrow (M.keys m) + let missing = M.keys $ M.difference wantedmap m + + unless (null missing) $ do + section "Missing data that would be used if set:" + showtable $ map mkrow missing + + section "How to set missing data:" + mapM_ putStrLn $ showSet $ + map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing + where + header = ["Field", "Context", "Used by"] + mkrow k@(field, Context context) = + [ shellEscape $ show field + , shellEscape context + , intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby + ] + usedby = mkUsedByMap hosts + wantedmap = M.fromList $ zip (M.keys usedby) (repeat "") + descmap = M.unions $ map (`mkPrivDataMap` id) hosts + section desc = putStrLn $ "\n" ++ desc + showtable rows = do + putStr $ unlines $ formatTable $ tableWithHeader header rows + +mkUsedByMap :: [Host] -> M.Map (PrivDataField, Context) [HostName] +mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h]) + +mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a +mkPrivDataMap host mkv = M.fromList $ + map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) + (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host) + +setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () +setPrivDataTo field context (PrivData value) = do + modifyPrivData set + putStrLn "Private data set." + where + set = M.insert (field, context) value + +modifyPrivData :: (PrivMap -> PrivMap) -> IO () +modifyPrivData f = modifyPrivData' (\m -> (f m, ())) + +modifyPrivData' :: (PrivMap -> (PrivMap, a)) -> IO a +modifyPrivData' f = do + makePrivDataDir + m <- decryptPrivData + let (m', r) = f m + privdata <- privDataFile + gpgEncrypt privdata (show m') + void $ boolSystem "git" [Param "add", File privdata] + return r + +decryptPrivData :: IO PrivMap +decryptPrivData = readPrivData <$> (gpgDecrypt =<< privDataFile) + +readPrivData :: String -> PrivMap +readPrivData = fromMaybe M.empty . readish + +readPrivDataFile :: FilePath -> IO PrivMap +readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f + +makePrivDataDir :: IO () +makePrivDataDir = createDirectoryIfMissing False privDataDir + +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. +instance IsInfo PrivInfo where + propagateInfo _ = True + +-- | Sets the context of any privdata that uses HostContext to the +-- provided name. +forceHostContext :: String -> PrivInfo -> PrivInfo +forceHostContext name i = PrivInfo $ S.map go (fromPrivInfo i) + where + go (f, d, HostContext ctx) = (f, d, HostContext (const $ ctx name)) diff --git a/src/Propellor/PrivData/Paths.hs b/src/Propellor/PrivData/Paths.hs @@ -0,0 +1,31 @@ +module Propellor.PrivData.Paths where + +import Utility.Exception +import System.FilePath +import Control.Applicative +import Prelude + +privDataDir :: FilePath +privDataDir = "privdata" + +privDataFile :: IO FilePath +privDataFile = allowRelocate $ privDataDir </> "privdata.gpg" + +privDataKeyring :: IO FilePath +privDataKeyring = allowRelocate $ privDataDir </> "keyring.gpg" + +privDataLocal :: FilePath +privDataLocal = privDataDir </> "local" + +privDataRelay :: String -> FilePath +privDataRelay host = privDataDir </> "relay" </> host + +-- Allow relocating files in privdata, by checking for a file +-- privdata/relocate, which contains the path to a subdirectory that +-- contains the files. +allowRelocate :: FilePath -> IO FilePath +allowRelocate f = reloc . lines + <$> catchDefaultIO "" (readFile (privDataDir </> "relocate")) + where + reloc (p:_) | not (null p) = privDataDir </> p </> takeFileName f + reloc _ = f diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} + +module Propellor.PropAccum + ( host + , Props(..) + , props + , (&) + , (&^) + , (!) + ) where + +import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core +import Propellor.Property + +import Data.Monoid +import Prelude + +-- | Defines a host and its properties. +-- +-- > host "example.com" $ props +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Props metatypes -> Host +host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) + +-- | Start accumulating a list of properties. +-- +-- Properties can be added to it using `(&)` etc. +props :: Props UnixLike +props = Props [] + +infixl 1 & +infixl 1 &^ +infixl 1 ! + +type family GetMetaTypes x +type instance GetMetaTypes (Property (MetaTypes t)) = MetaTypes t +type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t + +-- | Adds a property to a Props. +-- +-- Can add Properties and RevertableProperties +(&) + :: + ( IsProp p + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + , MetaTypes y ~ GetMetaTypes p + , CheckCombinable x y ~ 'CanCombine + ) + => Props (MetaTypes x) + -> p + -> Props (MetaTypes (Combine x y)) +Props c & p = Props (c ++ [toChildProperty p]) + +-- | Adds a property before any other properties. +(&^) + :: + ( IsProp p + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + , MetaTypes y ~ GetMetaTypes p + , CheckCombinable x y ~ 'CanCombine + ) + => Props (MetaTypes x) + -> p + -> Props (MetaTypes (Combine x y)) +Props c &^ p = Props (toChildProperty p : c) + +-- | Adds a property in reverted form. +(!) + -- -Wredundant-constraints is turned off because + -- this constraint appears redundant, but is actually + -- crucial. + :: (CheckCombinable x z ~ 'CanCombine) + => Props (MetaTypes x) + -> RevertableProperty (MetaTypes y) (MetaTypes z) + -> Props (MetaTypes (Combine x z)) +Props c ! p = Props (c ++ [toChildProperty (revert p)]) diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} + +module Propellor.Property ( + -- * Property combinators + requires + , before + , onChange + , onChangeFlagOnFail + , flagFile + , flagFile' + , check + , fallback + , revert + , applyToList + -- * Property descriptions + , describe + , (==>) + -- * Constructing properties + , Propellor + , property + , property' + , OuterMetaTypesWitness + , ensureProperty + , pickOS + , withOS + , unsupportedOS + , unsupportedOS' + , makeChange + , noChange + , doNothing + , endAction + -- * Property result checking + , UncheckedProperty + , unchecked + , changesFile + , changesFileContent + , isNewerThan + , checkResult + , Checkable + , assume +) where + +import System.FilePath +import Control.Monad +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.List +import Control.Applicative +import Data.Foldable hiding (and, elem) +import Prelude + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.ResultCheck +import Propellor.Types.MetaTypes +import Propellor.Types.Singletons +import Propellor.Info +import Propellor.EnsureProperty +import Utility.Exception +import Utility.Monad +import Utility.Misc +import Utility.Directory + +-- | Makes a perhaps non-idempotent Property be idempotent by using a flag +-- file to indicate whether it has run before. +-- Use with caution. +flagFile :: Property i -> FilePath -> Property i +flagFile p = flagFile' p . return + +flagFile' :: Property i -> IO FilePath -> Property i +flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do + flagfile <- liftIO getflagfile + go satisfy flagfile =<< liftIO (doesFileExist flagfile) + where + go _ _ True = return NoChange + go satisfy flagfile False = do + r <- satisfy + when (r == MadeChange) $ liftIO $ + unlessM (doesFileExist flagfile) $ do + createDirectoryIfMissing True (takeDirectory flagfile) + writeFile flagfile "" + return r + +-- | Indicates that the first property depends on the second, +-- so before the first is ensured, the second must be ensured. +-- +-- The combined property uses the description of the first property. +requires :: Combines x y => x -> y -> CombinedType x y +requires = combineWith + -- Run action of y, then x + (flip (<>)) + -- When reverting, run in reverse order. + (<>) + +-- | Combines together two properties, resulting in one property +-- that ensures the first, and if the first succeeds, ensures the second. +-- +-- The combined property uses the description of the first property. +before :: Combines x y => x -> y -> CombinedType x y +before = combineWith + -- Run action of x, then y + (<>) + -- When reverting, run in reverse order. + (flip (<>)) + +-- | Whenever a change has to be made for a Property, causes a hook +-- Property to also be run, but not otherwise. +onChange + :: (Combines x y) + => x + -> y + -> CombinedType x y +onChange = combineWith combiner revertcombiner + where + combiner p hook = do + r <- p + case r of + MadeChange -> do + r' <- hook + return $ r <> r' + _ -> return r + revertcombiner = (<>) + +-- | Same as `onChange` except that if property y fails, a flag file +-- is generated. On next run, if the flag file is present, property y +-- is executed even if property x doesn't change. +-- +-- With `onChange`, if y fails, the property x `onChange` y returns +-- `FailedChange`. But if this property is applied again, it returns +-- `NoChange`. This behavior can cause trouble... +onChangeFlagOnFail + :: (Combines x y) + => FilePath + -> x + -> y + -> CombinedType x y +onChangeFlagOnFail flagfile = combineWith combiner revertcombiner + where + combiner s1 s2 = do + r1 <- s1 + case r1 of + MadeChange -> flagFailed s2 + _ -> ifM (liftIO $ doesFileExist flagfile) + (flagFailed s2 + , return r1 + ) + revertcombiner = (<>) + flagFailed s = do + r <- s + liftIO $ case r of + FailedChange -> createFlagFile + _ -> removeFlagFile + return r + createFlagFile = unlessM (doesFileExist flagfile) $ do + createDirectoryIfMissing True (takeDirectory flagfile) + writeFile flagfile "" + removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile + +-- | Changes the description of a property. +describe :: IsProp p => p -> Desc -> p +describe = setDesc + +-- | Alias for @flip describe@ +(==>) :: IsProp (Property i) => Desc -> Property i -> Property i +(==>) = flip describe +infixl 1 ==> + +-- | Tries the first property, but if it fails to work, instead uses +-- the second. +fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2 +fallback = combineWith combiner revertcombiner + where + combiner a1 a2 = do + r <- a1 + if r == FailedChange + then a2 + else return r + revertcombiner = (<>) + +-- | Indicates that a Property may change a particular file. When the file +-- is modified in any way (including changing its permissions or mtime), +-- the property will return MadeChange instead of NoChange. +changesFile :: Checkable p i => p i -> FilePath -> Property i +changesFile p f = checkResult getstat comparestat p + where + getstat = catchMaybeIO $ getSymbolicLinkStatus f + comparestat oldstat = do + newstat <- getstat + return $ if samestat oldstat newstat then NoChange else MadeChange + samestat Nothing Nothing = True + samestat (Just a) (Just b) = and + -- everything except for atime + [ deviceID a == deviceID b + , fileID a == fileID b + , fileMode a == fileMode b + , fileOwner a == fileOwner b + , fileGroup a == fileGroup b + , specialDeviceID a == specialDeviceID b + , fileSize a == fileSize b + , modificationTimeHiRes a == modificationTimeHiRes b + , isBlockDevice a == isBlockDevice b + , isCharacterDevice a == isCharacterDevice b + , isNamedPipe a == isNamedPipe b + , isRegularFile a == isRegularFile b + , isDirectory a == isDirectory b + , isSymbolicLink a == isSymbolicLink b + , isSocket a == isSocket b + ] + samestat _ _ = False + +-- | Like `changesFile`, but compares the content of the file. +-- 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 + where + getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f + comparemd5 oldmd5 = do + newmd5 <- getmd5 + return $ if oldmd5 == newmd5 then NoChange else MadeChange + +-- | Determines if the first file is newer than the second file. +-- +-- This can be used with `check` to only run a command when a file +-- has changed. +-- +-- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") +-- > (cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db +-- +-- Or it can be used with `checkResult` to test if a command made a change. +-- +-- > checkResult (return ()) +-- > (\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases") +-- > (cmdProperty "newaliases" []) +-- +-- (If one of the files does not exist, the file that does exist is +-- considered to be the newer of the two.) +isNewerThan :: FilePath -> FilePath -> IO Bool +isNewerThan x y = do + mx <- mtime x + my <- mtime y + return (mx > my) + where + mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f + +-- | Picks one of the two input properties to use, +-- depending on the targeted OS. +-- +-- If both input properties support the targeted OS, then the +-- first will be used. +-- +-- The resulting property will use the description of the first property +-- no matter which property is used in the end. So, it's often a good +-- idea to change the description to something clearer. +-- +-- For example: +-- +-- > upgraded :: UnixLike +-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded) +-- > `describe` "OS upgraded" +-- +-- If neither input property supports the targeted OS, calls +-- `unsupportedOS`. Using the example above on a Fedora system would +-- fail that way. +pickOS + :: + ( SingKind ('KProxy :: KProxy ka) + , SingKind ('KProxy :: KProxy kb) + , DemoteRep ('KProxy :: KProxy ka) ~ [MetaType] + , DemoteRep ('KProxy :: KProxy kb) ~ [MetaType] + , SingI c + -- Would be nice to have this constraint, but + -- union will not generate metatypes lists with the same + -- order of OS's as is used everywhere else. So, + -- would need a type-level sort. + --, Union a b ~ c + ) + => Property (MetaTypes (a :: ka)) + -> Property (MetaTypes (b :: kb)) + -> Property (MetaTypes c) +pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] + where + -- This use of getSatisfy is safe, because both a and b + -- are added as children, so their info will propigate. + c = withOS (getDesc a) $ \_ o -> + if matching o a + then getSatisfy a + else if matching o b + then getSatisfy b + else unsupportedOS' + matching Nothing _ = False + matching (Just o) p = + Targeting (systemToTargetOS o) + `elem` + fromSing (proptype p) + proptype (Property t _ _ _ _) = t + +-- | Makes a property that is satisfied differently depending on specifics +-- of the host's operating system. +-- +-- > 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 ... +-- > _ -> unsupportedOS' +-- +-- Note that the operating system specifics may not be declared for all hosts, +-- which is where Nothing comes in. +withOS + :: (SingI metatypes) + => Desc + -> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result) + -> Property (MetaTypes metatypes) +withOS desc a = property desc $ a dummyoutermetatypes =<< getOS + where + -- Using this dummy value allows ensureProperty to be used + -- even though the inner property probably doesn't target everything + -- that the outer withOS property targets. + dummyoutermetatypes :: OuterMetaTypesWitness ('[]) + dummyoutermetatypes = OuterMetaTypesWitness sing + +-- | A property that always fails with an unsupported OS error. +unsupportedOS :: Property UnixLike +unsupportedOS = property "unsupportedOS" unsupportedOS' + +-- | Throws an error, for use in `withOS` when a property is lacking +-- support for an OS. +unsupportedOS' :: Propellor Result +unsupportedOS' = go =<< getOS + where + go Nothing = error "Unknown host OS is not supported by this property." + go (Just o) = error $ "This property is not implemented for " ++ show o + +-- | Undoes the effect of a RevertableProperty. +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 + +doNothing :: SingI t => Property (MetaTypes t) +doNothing = property "noop property" noChange + +-- | Registers an action that should be run at the very end, after +-- propellor has checks all the properties of a host. +endAction :: Desc -> (Result -> Propellor Result) -> Propellor () +endAction desc a = tell [EndAction desc a] diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Maintainer: Jelmer Vernooij <jelmer@samba.org> + +module Propellor.Property.Aiccu ( + installed, + restarted, + confPath, + UserName, + TunnelId, + hasConfig, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.File as File + +installed :: Property DebianLike +installed = Apt.installed ["aiccu"] + +restarted :: Property DebianLike +restarted = Service.restarted "aiccu" + +confPath :: FilePath +confPath = "/etc/aiccu.conf" + +type TunnelId = String + +config :: UserName -> TunnelId -> PrivData -> [File.Line] +config u t p = + [ "protocol tic" + , "server tic.sixxs.net" + , "username " ++ u + , "password " ++ privDataVal p + , "ipv6_interface sixxs" + , "tunnel_id " ++ t + , "daemonize true" + , "automatic true" + , "requiretls true" + , "makebeats true" + ] + +-- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId +-- and sixx.net UserName. +hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike) +hasConfig t u = prop `onChange` restarted + where + prop :: Property (HasInfo + UnixLike) + prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $ + property' "aiccu configured" . writeConfig + writeConfig getpassword w = getpassword $ ensureProperty w . go + go (Password u', p) = confPath `File.hasContentProtected` config u' t p + go (f, _) = error $ "Unexpected type of privdata: " ++ show f diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs @@ -0,0 +1,214 @@ +module Propellor.Property.Apache where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.LetsEncrypt as LetsEncrypt + +installed :: Property DebianLike +installed = Apt.installed ["apache2"] + +restarted :: Property DebianLike +restarted = Service.restarted "apache2" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "apache2" + +type ConfigLine = String + +type ConfigFile = [ConfigLine] + +siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike +siteEnabled domain cf = siteEnabled' domain cf <!> siteDisabled domain + +siteEnabled' :: Domain -> ConfigFile -> Property DebianLike +siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props + & siteAvailable domain cf + `requires` installed + `onChange` reloaded + & check (not <$> isenabled) + (cmdProperty "a2ensite" ["--quiet", domain]) + `requires` installed + `onChange` reloaded + where + isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain] + +siteDisabled :: Domain -> Property DebianLike +siteDisabled domain = combineProperties + ("apache site disabled " ++ domain) + (toProps $ map File.notPresent (siteCfg domain)) + `onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange) + `requires` installed + `onChange` reloaded + +siteAvailable :: Domain -> ConfigFile -> Property DebianLike +siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $ + toProps $ map tightenTargets $ + map (`File.hasContent` (comment:cf)) (siteCfg domain) + where + comment = "# deployed with propellor, do not modify" + +modEnabled :: String -> RevertableProperty DebianLike DebianLike +modEnabled modname = enable <!> disable + where + enable = check (not <$> isenabled) + (cmdProperty "a2enmod" ["--quiet", modname]) + `describe` ("apache module enabled " ++ modname) + `requires` installed + `onChange` reloaded + disable = check isenabled + (cmdProperty "a2dismod" ["--quiet", modname]) + `describe` ("apache module disabled " ++ modname) + `requires` installed + `onChange` reloaded + isenabled = boolSystem "a2query" [Param "-q", Param "-m", Param modname] + +-- | Make apache listen on the specified ports. +-- +-- Note that ports are also specified inside a site's config file, +-- so that also needs to be changed. +listenPorts :: [Port] -> Property DebianLike +listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps + `onChange` restarted + where + portline port = "Listen " ++ fromPort port + +-- This is a list of config files because different versions of apache +-- use different filenames. Propellor simply writes them all. +siteCfg :: Domain -> [FilePath] +siteCfg domain = + -- Debian pre-2.4 + [ "/etc/apache2/sites-available/" ++ domain + -- Debian 2.4+ + , "/etc/apache2/sites-available/" ++ domain ++ ".conf" + ] + +-- | Configure apache to use SNI to differentiate between +-- https hosts. +-- +-- This was off by default in apache 2.2.22. Newver versions enable +-- it by default. This property uses the filename used by the old version. +multiSSL :: Property DebianLike +multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $ + "/etc/apache2/conf.d/ssl" `File.hasContent` + [ "NameVirtualHost *:443" + , "SSLStrictSNIVHostCheck off" + ] + `describe` "apache SNI enabled" + `onChange` reloaded + +-- | Config file fragment that can be inserted into a <Directory> +-- stanza to allow global read access to the directory. +-- +-- Works with multiple versions of apache that have different ways to do +-- it. +allowAll :: ConfigLine +allowAll = unlines + [ "<IfVersion < 2.4>" + , "Order allow,deny" + , "allow from all" + , "</IfVersion>" + , "<IfVersion >= 2.4>" + , "Require all granted" + , "</IfVersion>" + ] + +-- | Config file fragment that can be inserted into a <VirtualHost> +-- stanza to allow apache to display directory index icons. +iconDir :: ConfigLine +iconDir = unlines + [ "<Directory \"/usr/share/apache2/icons\">" + , "Options Indexes MultiViews" + , "AllowOverride None" + , allowAll + , " </Directory>" + ] + +type WebRoot = FilePath + +-- | A basic virtual host, publishing a directory, and logging to +-- the combined apache log file. Not https capable. +virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike +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 + , "DocumentRoot " ++ docroot + , "ErrorLog /var/log/apache2/error.log" + , "LogLevel warn" + , "CustomLog /var/log/apache2/access.log combined" + , "ServerSignature On" + ] + ++ addedcfg ++ + [ "</VirtualHost>" + ] + +-- | A virtual host using https, with the certificate obtained +-- using `Propellor.Property.LetsEncrypt.letsEncrypt`. +-- +-- http connections are redirected to https. +-- +-- Example: +-- +-- > httpsVirtualHost "example.com" "/var/www" +-- > (LetsEncrypt.AgreeTOS (Just "me@my.domain")) +-- +-- Note that reverting this property does not remove the certificate from +-- letsencrypt's cert store. +httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike +httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos [] + +-- | Like `httpsVirtualHost` but with additional config lines added. +httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike +httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown + where + setup = setuphttp + `requires` modEnabled "rewrite" + `requires` modEnabled "ssl" + `before` setuphttps + teardown = siteDisabled 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. + ("IncludeOptional " ++ sslconffile "*") + : vhost (Port 80) + [ "RewriteEngine On" + -- Pass through .well-known directory on http for the + -- letsencrypt acme challenge. + , "RewriteRule ^/.well-known/(.*) - [L]" + -- Everything else redirects to https + , "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" + ] + 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 + ] + sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf" + vhost p ls = + [ "<VirtualHost *:" ++ fromPort p ++">" + , "ServerName " ++ domain ++ ":" ++ fromPort p + , "DocumentRoot " ++ docroot + , "ErrorLog /var/log/apache2/error.log" + , "LogLevel warn" + , "CustomLog /var/log/apache2/access.log combined" + , "ServerSignature On" + ] ++ ls ++ addedcfg ++ + [ "</VirtualHost>" + ] diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Apt where + +import Data.Maybe +import Data.List +import System.IO +import Control.Monad +import Control.Applicative +import Prelude + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Service as Service +import Propellor.Property.File (Line) + +sourcesList :: FilePath +sourcesList = "/etc/apt/sources.list" + +type Url = String +type Section = String + +type SourcesGenerator = DebianSuite -> [Line] + +showSuite :: DebianSuite -> String +showSuite (Stable s) = s +showSuite Testing = "testing" +showSuite Unstable = "unstable" +showSuite Experimental = "experimental" + +backportSuite :: DebianSuite -> Maybe String +backportSuite (Stable s) = Just (s ++ "-backports") +backportSuite _ = Nothing + +stableUpdatesSuite :: DebianSuite -> Maybe String +stableUpdatesSuite (Stable s) = Just (s ++ "-updates") +stableUpdatesSuite _ = Nothing + +debLine :: String -> Url -> [Section] -> Line +debLine suite mirror sections = unwords $ + ["deb", mirror, suite] ++ sections + +srcLine :: Line -> Line +srcLine l = case words l of + ("deb":rest) -> unwords $ "deb-src" : rest + _ -> "" + +stdSections :: [Section] +stdSections = ["main", "contrib", "non-free"] + +binandsrc :: String -> SourcesGenerator +binandsrc url suite = catMaybes + [ Just l + , Just $ srcLine l + , bl + , srcLine <$> bl + ] + where + l = debLine (showSuite suite) url stdSections + bl = do + 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" + +-- | Only available for Stable and Testing +securityUpdates :: SourcesGenerator +securityUpdates suite + | isStable suite || suite == Testing = + let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections + 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. +stdSourcesList :: Property Debian +stdSourcesList = withOS "standard sources.list" $ \w o -> case o of + (Just (System (Debian _ suite) _)) -> + ensureProperty w $ stdSourcesListFor suite + _ -> unsupportedOS' + +stdSourcesListFor :: DebianSuite -> Property Debian +stdSourcesListFor suite = stdSourcesList' suite [] + +-- | Adds additional sources.list generators. +-- +-- 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) + where + generators = [debCdn, kernelOrg, securityUpdates] ++ more + +setSourcesList :: [Line] -> Property DebianLike +setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update + +setSourcesListD :: [Line] -> FilePath -> Property DebianLike +setSourcesListD ls basename = f `File.hasContent` ls `onChange` update + where + f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" + +runApt :: [String] -> UncheckedProperty DebianLike +runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv + +noninteractiveEnv :: [(String, String)] +noninteractiveEnv = + [ ("DEBIAN_FRONTEND", "noninteractive") + , ("APT_LISTCHANGES_FRONTEND", "none") + ] + +-- | Have apt update its lists of packages, but without upgrading anything. +update :: Property DebianLike +update = combineProperties ("apt update") $ props + & pendingConfigured + & runApt ["update"] + `assume` MadeChange + +-- | Have apt upgrade packages, adding new packages and removing old as +-- necessary. Often used in combination with the `update` property. +upgrade :: Property DebianLike +upgrade = upgrade' "dist-upgrade" + +upgrade' :: String -> Property DebianLike +upgrade' p = combineProperties ("apt " ++ p) $ props + & pendingConfigured + & runApt ["-y", p] + `assume` MadeChange + +-- | Have apt upgrade packages, but never add new packages or remove +-- old packages. Not suitable for upgrading acrocess major versions +-- of the distribution. +safeUpgrade :: Property DebianLike +safeUpgrade = upgrade' "upgrade" + +-- | Have dpkg try to configure any packages that are not fully configured. +pendingConfigured :: Property DebianLike +pendingConfigured = tightenTargets $ + cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv + `assume` MadeChange + `describe` "dpkg configured pending" + +type Package = String + +installed :: [Package] -> Property DebianLike +installed = installed' ["-y"] + +installed' :: [String] -> [Package] -> Property DebianLike +installed' params ps = robustly $ check (not <$> isInstalled' ps) go + `describe` unwords ("apt installed":ps) + where + go = runApt (params ++ ["install"] ++ ps) + +installedBackport :: [Package] -> Property Debian +installedBackport ps = withOS desc $ \w o -> case o of + (Just (System (Debian _ suite) _)) -> case backportSuite suite of + Nothing -> unsupportedOS' + Just bs -> ensureProperty w $ + runApt (["install", "-t", bs, "-y"] ++ ps) + `changesFile` dpkgStatus + _ -> unsupportedOS' + where + desc = unwords ("apt installed backport":ps) + +-- | Minimal install of package, without recommends. +installedMin :: [Package] -> Property DebianLike +installedMin = installed' ["--no-install-recommends", "-y"] + +removed :: [Package] -> Property DebianLike +removed ps = check (any (== IsInstalled) <$> getInstallStatus ps) + (runApt (["-y", "remove"] ++ ps)) + `describe` unwords ("apt removed":ps) + +buildDep :: [Package] -> Property DebianLike +buildDep ps = robustly $ go + `changesFile` dpkgStatus + `describe` unwords ("apt build-dep":ps) + where + go = runApt $ ["-y", "build-dep"] ++ ps + +-- | Installs the build deps for the source package unpacked +-- in the specifed directory, with a dummy package also +-- installed so that autoRemove won't remove them. +buildDepIn :: FilePath -> Property DebianLike +buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv + `changesFile` dpkgStatus + `requires` installedMin ["devscripts", "equivs"] + where + cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove" + +-- | Package installation may fail becuse the archive has changed. +-- Run an update in that case and retry. +robustly :: Property DebianLike -> Property DebianLike +robustly p = p `fallback` (update `before` p) + +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 parse . lines <$> policy + where + parse l + | "Installed: (none)" `isInfixOf` l = Just NotInstalled + | "Installed: " `isInfixOf` l = Just IsInstalled + | otherwise = Nothing + policy = do + environ <- addEntry "LANG" "C" <$> getEnvironment + readProcessEnv "apt-cache" ("policy":ps) (Just environ) + +autoRemove :: Property DebianLike +autoRemove = runApt ["-y", "autoremove"] + `changesFile` dpkgStatus + `describe` "apt autoremove" + +-- | Enables unattended upgrades. Revert to disable. +unattendedUpgrades :: RevertableProperty DebianLike DebianLike +unattendedUpgrades = enable <!> disable + where + enable = setup True + `before` Service.running "cron" + `before` configure + -- work around http://bugs.debian.org/812380 + `before` File.notPresent "/etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist" + disable = setup False + + setup enabled = (if enabled then installed else removed) ["unattended-upgrades"] + `onChange` reConfigure "unattended-upgrades" + [("unattended-upgrades/enable_auto_updates" , "boolean", v)] + `describe` ("unattended upgrades " ++ v) + where + v + | enabled = "true" + | otherwise = "false" + + configure :: Property DebianLike + configure = propertyList "unattended upgrades configured" $ props + & enableupgrading + & unattendedconfig `File.containsLine` "Unattended-Upgrade::Mail \"root\";" + where + enableupgrading :: Property DebianLike + enableupgrading = withOS "unattended upgrades configured" $ \w o -> + case o of + -- the package defaults to only upgrading stable + (Just (System (Debian _ suite) _)) + | not (isStable suite) -> ensureProperty w $ + unattendedconfig + `File.containsLine` + ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") + _ -> noChange + unattendedconfig = "/etc/apt/apt.conf.d/50unattended-upgrades" + +-- | Enable periodic updates (but not upgrades), including download +-- of packages. +periodicUpdates :: Property DebianLike +periodicUpdates = tightenTargets $ "/etc/apt/apt.conf.d/02periodic" `File.hasContent` + [ "APT::Periodic::Enable \"1\";" + , "APT::Periodic::Update-Package-Lists \"1\";" + , "APT::Periodic::Download-Upgradeable-Packages \"1\";" + , "APT::Periodic::Verbose \"1\";" + ] + +type DebconfTemplate = String +type DebconfTemplateType = String +type DebconfTemplateValue = String + +-- | Preseeds debconf values and reconfigures the package so it takes +-- effect. +reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike +reConfigure package vals = tightenTargets $ + reconfigure + `requires` setselections + `describe` ("reconfigure " ++ package) + where + setselections :: Property DebianLike + setselections = property "preseed" $ + if null vals + then noChange + else makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "debconf-set-selections" []) $ \h -> do + forM_ vals $ \(tmpl, tmpltype, value) -> + hPutStrLn h $ unwords [package, tmpl, tmpltype, value] + hClose h + reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv + `assume` MadeChange + +-- | Ensures that a service is installed and running. +-- +-- Assumes that there is a 1:1 mapping between service names and apt +-- package names. +serviceInstalledRunning :: Package -> Property DebianLike +serviceInstalledRunning svc = Service.running svc `requires` installed [svc] + +data AptKey = AptKey + { keyname :: String + , pubkey :: String + } + +trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike +trustsKey k = trustsKey' k <!> untrustKey k + +trustsKey' :: AptKey -> Property DebianLike +trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do + withHandle StdinHandle createProcessSuccess + (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do + hPutStr h (pubkey k) + hClose h + nukeFile $ f ++ "~" -- gpg dropping + where + desc = "apt trusts key " ++ keyname k + f = aptKeyFile k + +untrustKey :: AptKey -> Property DebianLike +untrustKey = tightenTargets . File.notPresent . aptKeyFile + +aptKeyFile :: AptKey -> FilePath +aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg" + +-- | Cleans apt's cache of downloaded packages to avoid using up disk +-- space. +cacheCleaned :: Property DebianLike +cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"] + `assume` NoChange + `describe` "apt cache cleaned" + +-- | Add a foreign architecture to dpkg and apt. +hasForeignArch :: String -> Property DebianLike +hasForeignArch arch = check notAdded (add `before` update) + `describe` ("dpkg has foreign architecture " ++ arch) + where + notAdded = (notElem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"] + add = cmdProperty "dpkg" ["--add-architecture", arch] + `assume` MadeChange + +dpkgStatus :: FilePath +dpkgStatus = "/var/lib/dpkg/status" diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs @@ -0,0 +1,115 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- Personal Package Archives +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 + +-- | Ensure software-properties-common is installed. +installed :: Property DebianLike +installed = Apt.installed ["software-properties-common"] + +-- | Personal Package Archives are people's individual package +-- contributions to the Buntish distro. There's a well-known format for +-- representing them, and this type represents that. It's also an instance +-- of 'Show' and 'IsString' so it can work with 'OverloadedStrings'. +-- More on PPAs can be found at <https://help.launchpad.net/Packaging/PPA> +data PPA = PPA + { ppaAccount :: String -- ^ The Launchpad account hosting this archive. + , ppaArchive :: String -- ^ The name of the archive. + } deriving (Eq, Ord) + +instance Show PPA where + show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p] + +instance IsString PPA where + -- | Parse strings like "ppa:zfs-native/stable" into a PPA. + fromString s = + let + [_, ppa] = split "ppa:" s + [acct, arch] = split "/" ppa + in + PPA acct arch + +-- | Adds a PPA to the local system repositories. +addPpa :: PPA -> Property DebianLike +addPpa p = + cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv + `assume` MadeChange + `describe` ("Added PPA " ++ (show p)) + `requires` installed + +-- | A repository key ID to be downloaded with apt-key. +data AptKeyId = AptKeyId + { akiName :: String + , akiId :: String + , 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]) + where + akcmd = + tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId] + keyTrusted = + let + pks ls = concatMap (drop 1 . split "/") + $ concatMap (take 1 . drop 1 . words) + $ filter (\l -> "pub" `isPrefixOf` l) + $ lines ls + nkid = take 8 (akiId keyId) + in + (isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"] + +-- | 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. +-- +-- | FIXME there's apparently an optional "options" fragment that I've +-- definitely not parsed here. +data AptSource = AptSource + { asURL :: Apt.Url -- ^ The URL hosting the repository + , asSuite :: String -- ^ The operating system suite + , 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 IsString AptSource where + fromString s = + let + url:suite:comps = drop 1 . words $ s + in + AptSource url suite comps + +-- | A repository for apt-add-source, either a PPA or a regular repository line. +data AptRepository = AptRepositoryPPA PPA | AptRepositorySource AptSource + +-- | Adds an 'AptRepository' using apt-add-source. +addRepository :: AptRepository -> Property DebianLike +addRepository (AptRepositoryPPA p) = addPpa p +addRepository (AptRepositorySource src) = + check repoExists addSrc + `describe` unwords ["Adding APT repository", show src] + `requires` installed + where + allSourceLines = + readProcess "/bin/sh" ["-c", "cat /etc/apt/sources.list /etc/apt/sources.list.d/*"] + activeSources = map (\s -> fromString s :: AptSource ) + . filter (not . isPrefixOf "#") + . filter (/= "") . lines <$> allSourceLines + repoExists = isInfixOf [src] <$> activeSources + addSrc = cmdProperty "apt-add-source" [show src] diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs @@ -0,0 +1,149 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the Attic backup tool <https://attic-backup.org/> + +module Propellor.Property.Attic + ( installed + , repoExists + , init + , restored + , 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 Data.List (intercalate) + +type AtticParam = String + +type AtticRepo = FilePath + +installed :: Property DebianLike +installed = Apt.installed ["attic"] + +repoExists :: AtticRepo -> IO Bool +repoExists repo = boolSystem "attic" [Param "list", File repo] + +-- | Inits a new attic repository +init :: AtticRepo -> Property DebianLike +init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" initargs) + `requires` installed + where + initargs = + [ "init" + , backupdir + ] + +-- | Restores a directory from an attic 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 -> AtticRepo -> Property DebianLike +restored dir backupdir = go `requires` installed + where + go :: Property DebianLike + go = property (dir ++ " restored by attic") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "attic-restore" $ \tmpdir -> do + ok <- boolSystem "attic" $ + [ Param "extract" + , Param backupdir + , Param 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 attic 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: +-- +-- > & Attic.backup "/srv/git" "root@myserver:/mnt/backup/git.attic" Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Attic.KeepDays 7, Attic.KeepWeeks 4, Attic.KeepMonths 6, Attic.KeepYears 1] +-- +-- Note that this property does not make attic encrypt the backup +-- repository. +-- +-- Since attic uses a fair amount of system resources, only one attic +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp + `requires` restored dir backupdir + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc + `requires` installed + where + desc = backupdir ++ " attic backup" + cronjob = Cron.niceJob ("attic_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-attic.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "attic" + , "create" + , "--stats" + ] + ++ map shellEscape extraargs ++ + [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "attic" + , "prune" + , shellEscape backupdir + ] + ++ + map keepParam kp + +-- | Constructs an AtticParam 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 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 + +-- | 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 attic's man page for details. +data KeepPolicy + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs @@ -0,0 +1,155 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the Borg backup tool <https://github.com/borgbackup> + +module Propellor.Property.Borg + ( installed + , repoExists + , init + , restored + , 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 Data.List (intercalate) + +type BorgParam = String + +type BorgRepo = FilePath + +installed :: Property DebianLike +installed = withOS desc $ \w o -> case o of + (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $ + Apt.installedBackport ["borgbackup"] + _ -> ensureProperty w $ + Apt.installed ["borgbackup"] + where + desc = "installed borgbackup" + +repoExists :: BorgRepo -> IO Bool +repoExists repo = boolSystem "borg" [Param "list", File repo] + +-- | Inits a new borg repository +init :: BorgRepo -> Property DebianLike +init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initargs) + `requires` installed + where + initargs = + [ "init" + , backupdir + ] + +-- | Restores a directory from an borg 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 -> BorgRepo -> Property DebianLike +restored dir backupdir = go `requires` installed + where + go :: Property DebianLike + go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do + ok <- boolSystem "borg" $ + [ Param "extract" + , Param backupdir + , Param 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 borg 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: +-- +-- > & Borg.backup "/srv/git" "root@myserver:/mnt/backup/git.borg" Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Borg.KeepDays 7, Borg.KeepWeeks 4, Borg.KeepMonths 6, Borg.KeepYears 1] +-- +-- Note that this property does not make borg encrypt the backup +-- repository. +-- +-- Since borg uses a fair amount of system resources, only one borg +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike +backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp + `requires` restored dir backupdir + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc + `requires` installed + where + desc = backupdir ++ " borg backup" + cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-borg.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "borg" + , "create" + , "--stats" + ] + ++ map shellEscape extraargs ++ + [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "borg" + , "prune" + , shellEscape backupdir + ] + ++ + map keepParam kp + +-- | Constructs an BorgParam 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 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 + +-- | 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 borg's man page for details. +data KeepPolicy + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs @@ -0,0 +1,135 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.Ccache ( + hasCache, + hasLimits, + Limit(..), + DataSize, +) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +import Utility.FileMode +import Utility.DataUnits +import System.Posix.Files + +-- | Limits on the size of a ccache +data Limit + -- | The maximum size of the cache, as a string such as "4G" + = MaxSize DataSize + -- | The maximum number of files in the cache + | MaxFiles Integer + -- | A cache with no limit specified + | NoLimit + | Limit :+ Limit + +instance Monoid Limit where + mempty = NoLimit + mappend = (:+) + +-- | A string that will be parsed to get a data size. +-- +-- Examples: "100 megabytes" or "0.5tb" +type DataSize = String + +maxSizeParam :: DataSize -> Maybe String +maxSizeParam s = readSize dataUnits s + >>= \sz -> Just $ "--max-size=" ++ ccacheSizeUnits sz + +-- Generates size units as used in ccache.conf. The smallest unit we can +-- specify in a ccache config files is a kilobyte +ccacheSizeUnits :: Integer -> String +ccacheSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz) + where + cfgfileunits :: [Unit] + cfgfileunits = + [ Unit (p 4) "Ti" "terabyte" + , Unit (p 3) "Gi" "gigabyte" + , Unit (p 2) "Mi" "megabyte" + , Unit (p 1) "Ki" "kilobyte" + ] + p :: Integer -> Integer + p n = 1024^n + +-- | Set limits on a given ccache +hasLimits :: FilePath -> Limit -> Property DebianLike +path `hasLimits` limit = go `requires` installed + where + go + | null params' = doNothing + -- We invoke ccache itself to set the limits, so that it can + -- handle replacing old limits in the config file, duplicates + -- etc. + | null errors = + cmdPropertyEnv "ccache" params' [("CCACHE_DIR", path)] + `changesFileContent` (path </> "ccache.conf") + | otherwise = property "couldn't parse ccache limits" $ + errorMessage $ unlines errors + + params = limitToParams limit + (errors, params') = partitionEithers params + +limitToParams :: Limit -> [Either String String] +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 (l1 :+ l2) = limitToParams l1 <> limitToParams l2 + +-- | Configures a ccache in /var/cache for a group +-- +-- If you say +-- +-- > & (Group "foo") `Ccache.hasGroupCache` +-- > (Ccache.MaxSize "4G" <> Ccache.MaxFiles 10000) +-- +-- you instruct propellor to create a ccache in /var/cache/ccache-foo owned and +-- writeable by the foo group, with a maximum cache size of 4GB or 10000 files. +hasCache :: Group -> Limit -> RevertableProperty DebianLike UnixLike +group@(Group g) `hasCache` limit = (make `requires` installed) <!> delete + where + make = propertyList ("ccache for " ++ g ++ " group exists") $ props + & File.dirExists path + & File.ownerGroup path (User "root") group + & File.mode path (combineModes $ + readModes ++ executeModes ++ + [ ownerWriteMode + , groupWriteMode + , setGroupIDMode + ]) `onChange` fixSetgidBit + -- here, we use onChange to catch upgrades from + -- 3.0.5 where the setGroupIDMode line was not + -- present + & hasLimits path limit + + delete = check (doesDirectoryExist path) $ + cmdProperty "rm" ["-r", path] `assume` MadeChange + `describe` ("ccache for " ++ g ++ " does not exist") + + -- Here we deal with a bug in Propellor 3.0.5. If the ccache was + -- created with that version, it will not have the setgid bit set. That + -- means its subdirectories won't have inherited the setgid bit, and + -- then the files in those directories won't be owned by group sbuild. + -- This breaks ccache. + fixSetgidBit :: Property UnixLike + fixSetgidBit = + (cmdProperty "find" + [ path + , "-type", "d" + , "-exec", "chmod", "g+s" + , "{}", "+" + ] `assume` MadeChange) + `before` + (cmdProperty "chown" + [ "-R" + , "root:" ++ g + , path + ] `assume` MadeChange) + + path = "/var/cache/ccache-" ++ g + +installed :: Property DebianLike +installed = Apt.installed ["ccache"] diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} + +module Propellor.Property.Chroot ( + debootstrapped, + bootstrapped, + provisioned, + Chroot(..), + ChrootBootstrapper(..), + Debootstrapped(..), + ChrootTarball(..), + noServices, + inChroot, + -- * Internal use + provisioned', + propagateChrootInfo, + propellChroot, + chain, + chrootSystem, +) where + +import Propellor.Base +import Propellor.Container +import Propellor.Types.CmdLine +import Propellor.Types.Chroot +import Propellor.Types.Info +import Propellor.Types.Core +import Propellor.Property.Chroot.Util +import qualified Propellor.Property.Debootstrap as Debootstrap +import qualified Propellor.Property.Systemd.Core as Systemd +import qualified Propellor.Property.File as File +import qualified Propellor.Shim as Shim +import Propellor.Property.Mount +import Utility.FileMode + +import 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. +data Chroot where + Chroot :: ChrootBootstrapper b => FilePath -> b -> 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) + +chrootSystem :: Chroot -> Maybe System +chrootSystem = fromInfoVal . fromInfo . containerInfo + +instance Show Chroot where + show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) + +-- | Class of things that can do initial bootstrapping of an operating +-- System in a chroot. +class ChrootBootstrapper b where + -- | Do initial bootstrapping of an operating system in a chroot. + -- If the operating System is not supported, return + -- Left error message. + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux) + +-- | Use this to bootstrap a chroot by extracting a tarball. +-- +-- The tarball is expected to contain a root directory (no top-level +-- directory, also known as a "tarbomb"). +-- It may be optionally compressed with any format `tar` knows how to +-- detect automatically. +data ChrootTarball = ChrootTarball FilePath + +instance ChrootBootstrapper ChrootTarball where + buildchroot (ChrootTarball tb) _ loc = Right $ + tightenTargets $ extractTarball loc tb + +extractTarball :: FilePath -> FilePath -> Property UnixLike +extractTarball target src = check (unpopulated target) $ + cmdProperty "tar" params + `assume` MadeChange + `requires` File.dirExists target + where + params = + [ "-C" + , target + , "-xf" + , src + ] + +-- | Use this to bootstrap a chroot with debootstrap. +data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig + +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 (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." + Nothing -> Left "Cannot debootstrap; OS not specified" + where + debootstrap s = Debootstrap.built loc s cf + +-- | Defines a Chroot at the given location, built with debootstrap. +-- +-- Properties can be added to configure the Chroot. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. +-- +-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props +-- > & osDebian Unstable X86_64 +-- > & Apt.installed ["ghc", "haskell-platform"] +-- > & ... +debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot +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) + +-- | Ensures that the chroot exists and is provisioned according to its +-- properties. +-- +-- Reverting this property removes the chroot. Anything mounted inside it +-- 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' + :: (Property Linux -> Property (HasInfo + Linux)) + -> Chroot + -> Bool + -> RevertableProperty (HasInfo + Linux) Linux +provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = + (propigator $ setup `describe` chrootDesc c "exists") + <!> + (teardown `describe` chrootDesc c "removed") + where + setup :: Property Linux + setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly + `requires` built + + built = case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> p + Left e -> cantbuild e + + cantbuild e = property (chrootDesc c "built") (error e) + + teardown :: Property Linux + teardown = check (not <$> unpopulated loc) $ + 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 + +chrootInfo :: Chroot -> Info +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 + let d = localdir </> shimdir c + let me = localdir </> "propellor" + shim <- liftIO $ ifM (doesDirectoryExist d) + ( pure (Shim.file me d) + , Shim.setup me Nothing d + ) + ifM (liftIO $ bindmount shim) + ( chainprovision shim + , return FailedChange + ) + where + bindmount shim = ifM (doesFileExist (loc ++ shim)) + ( return True + , do + let mntpnt = loc ++ localdir + createDirectoryIfMissing True mntpnt + boolSystem "mount" + [ Param "--bind" + , File localdir, File mntpnt + ] + ) + + chainprovision shim = do + parenthost <- asks hostName + cmd <- liftIO $ toChain parenthost c systemdonly + pe <- liftIO standardPathEnv + (p, cleanup) <- liftIO $ mkproc + [ shim + , "--continue" + , show cmd + ] + let p' = p { env = Just pe } + r <- liftIO $ withHandle StdoutHandle createProcessSuccess p' + processChainOutput + liftIO cleanup + return r + +toChain :: HostName -> Chroot -> Bool -> IO CmdLine +toChain parenthost (Chroot loc _ _) systemdonly = do + onconsole <- isConsole <$> getMessageHandle + return $ ChrootChain parenthost loc systemdonly onconsole + +chain :: [Host] -> CmdLine -> IO () +chain hostlist (ChrootChain hn loc systemdonly onconsole) = + case findHostNoAlias hostlist hn of + Nothing -> errorMessage ("cannot find host " ++ hn) + Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of + Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) + Just h -> go h + where + 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 +chain _ _ = errorMessage "bad chain command" + +inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do + mountproc + return (proc "chroot" (loc:cmd), cleanup) + where + -- /proc needs to be mounted in the chroot for the linker to use + -- /proc/self/exe which is necessary for some commands to work + mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ + void $ mount "proc" "proc" procloc mempty + + procloc = loc </> "proc" + + cleanup + | keepprocmounted = noop + | otherwise = whenM (elem procloc <$> mountPointsBelow loc) $ + umountLazy procloc + +provisioningLock :: FilePath -> FilePath +provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock" + +shimdir :: Chroot -> FilePath +shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim" + +mungeloc :: FilePath -> String +mungeloc = replace "/" "_" + +chrootDesc :: Chroot -> String -> String +chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc + +-- | Adding this property to a chroot prevents daemons and other services +-- from being started, which is often something you want to prevent when +-- building a chroot. +-- +-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d> +-- script that does not let any daemons be started by packages that use +-- invoke-rc.d. Reverting the property removes the script. +-- +-- This property has no effect on non-Debian systems. +noServices :: RevertableProperty UnixLike UnixLike +noServices = setup <!> teardown + where + f = "/usr/sbin/policy-rc.d" + script = [ "#!/bin/sh", "exit 101" ] + setup = combineProperties "no services started" $ toProps + [ File.hasContent f script + , File.mode f (combineModes (readModes ++ executeModes)) + ] + teardown = File.notPresent f + +-- | Check if propellor is currently running within a chroot. +-- +-- This allows properties to check and avoid performing actions that +-- should not be done in a chroot. +inChroot :: Propellor Bool +inChroot = extract . fromMaybe (InChroot False) . fromInfoVal <$> askInfo + where + extract (InChroot b) = b + +setInChroot :: Host -> Host +setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) } + +newtype InChroot = InChroot Bool + deriving (Typeable, Show) diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs @@ -0,0 +1,33 @@ +module Propellor.Property.Chroot.Util where + +import Propellor.Property.Mount + +import Utility.Exception +import Utility.Env +import Utility.Directory + +import Control.Applicative +import Prelude + +-- | When chrooting, it's useful to ensure that PATH has all the standard +-- directories in it. This adds those directories to whatever PATH is +-- already set. +standardPathEnv :: IO [(String, String)] +standardPathEnv = do + path <- getEnvDefault "PATH" "/bin" + addEntry "PATH" (path ++ stdPATH) + <$> getEnvironment + +stdPATH :: String +stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + +-- | Removes the contents of a chroot. First, unmounts any filesystems +-- mounted within it. +removeChroot :: FilePath -> IO () +removeChroot c = do + unmountBelow c + removeDirectoryRecursive c + +-- | Returns true if a chroot directory is empty. +unpopulated :: FilePath -> IO Bool +unpopulated d = null <$> catchDefaultIO [] (dirContents d) diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE PackageImports #-} + +-- | This module lets you construct Properties by running commands and +-- scripts. To get from an `UncheckedProperty` to a `Property`, it's +-- up to the user to check if the command made a change to the system. +-- +-- The best approach is to `check` a property, so that the command is only +-- run when it needs to be. With this method, you avoid running the +-- `cmdProperty` unnecessarily. +-- +-- > check (not <$> userExists "bob") +-- > (cmdProperty "useradd" ["bob"]) +-- +-- Sometimes it's just as expensive to check a property as it would be to +-- run the command that ensures the property. So you can let the command +-- run every time, and use `changesFile` or `checkResult` to determine if +-- anything changed: +-- +-- > cmdProperty "chmod" ["600", "/etc/secret"] +-- > `changesFile` "/etc/secret" +-- +-- Or you can punt and `assume` a change was made, but then propellor will +-- always say it make a change, and `onChange` will always fire. +-- +-- > cmdProperty "service" ["foo", "reload"] +-- > `assume` MadeChange + +module Propellor.Property.Cmd ( + -- * Constricting properties running commands and scripts + cmdProperty, + cmdProperty', + cmdPropertyEnv, + Script, + scriptProperty, + userScriptProperty, + -- * Lower-level interface for running commands + CommandParam(..), + boolSystem, + boolSystemEnv, + safeSystem, + safeSystemEnv, + shellEscape, + createProcess, + waitForProcess, +) where + +import Data.List +import "mtl" Control.Monad.Reader +import Control.Applicative +import Prelude + +import Propellor.Types +import Propellor.Property +import Utility.SafeCommand +import Utility.Env +import Utility.Process (createProcess, CreateProcess, waitForProcess) + +-- | A property that can be satisfied by running a command. +-- +-- The command must exit 0 on success. +cmdProperty :: String -> [String] -> UncheckedProperty UnixLike +cmdProperty cmd params = cmdProperty' cmd params id + +cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty UnixLike +cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $ + cmdResult <$> boolSystem' cmd (map Param params) mkprocess + where + desc = unwords $ cmd : params + +cmdResult :: Bool -> Result +cmdResult False = FailedChange +cmdResult True = NoChange + +-- | A property that can be satisfied by running a command, +-- with added environment variables in addition to the standard +-- environment. +cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty UnixLike +cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do + env' <- addEntries env <$> getEnvironment + cmdResult <$> boolSystemEnv cmd (map Param params) (Just env') + where + desc = unwords $ cmd : params + +-- | A series of shell commands. (Without a leading hashbang.) +type Script = [String] + +-- | A property that can be satisfied by running a script. +scriptProperty :: Script -> UncheckedProperty UnixLike +scriptProperty script = cmdProperty "sh" ["-c", shellcmd] + where + shellcmd = intercalate " ; " ("set -e" : script) + +-- | A property that can satisfied by running a script +-- as user (cd'd to their home directory). +userScriptProperty :: User -> Script -> UncheckedProperty UnixLike +userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user] + where + shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Propellor properties can be made to run concurrently, using this +-- module. This can speed up propellor, at the expense of using more CPUs +-- and other resources. +-- +-- It's up to you to make sure that properties that you make run concurrently +-- don't implicitly depend on one-another. The worst that can happen +-- though, is that propellor fails to ensure some of the properties, +-- and tells you what went wrong. +-- +-- Another potential problem is that output of concurrent properties could +-- interleave into a scrambled mess. This is mostly prevented; all messages +-- output by propellor are concurrency safe, including `errorMessage`, +-- `infoMessage`, etc. However, if you write a property that directly +-- uses `print` or `putStrLn`, you can still experience this problem. +-- +-- Similarly, when properties run external commands, the command's output +-- can be a problem for concurrency. No need to worry; +-- `Propellor.Property.Cmd.createProcess` is concurrent output safe +-- (it actually uses `Propellor.Message.createProcessConcurrent`), and +-- everything else in propellor that runs external commands is built on top +-- of that. Of course, if you import System.Process and use it in a +-- property, you can bypass that and shoot yourself in the foot. +-- +-- Finally, anything that directly accesses the tty can bypass +-- these protections. That's sometimes done for eg, password prompts. +-- A well-written property should avoid running interactive commands +-- anyway. + +module Propellor.Property.Concurrent ( + concurrently, + concurrentList, + props, + getNumProcessors, + concurrentSatisfy, +) where + +import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes + +import Control.Concurrent +import qualified Control.Concurrent.Async as A +import GHC.Conc (getNumProcessors) +import Control.Monad.RWS.Strict + +-- | Ensures two properties concurrently. +-- +-- > & foo `concurrently` bar +-- +-- To ensure three properties concurrently, just use this combinator twice: +-- +-- > & foo `concurrently` bar `concurrently` baz +concurrently + :: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2)) + => p1 + -> p2 + -> CombinedType p1 p2 +concurrently p1 p2 = (combineWith go go p1 p2) + `describe` d + where + d = getDesc p1 ++ " `concurrently` " ++ getDesc 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 + n <- liftIO getNumProcessors + withCapabilities n $ + concurrentSatisfy a1 a2 + +-- | Ensures all the properties in the list, with a specified amount of +-- concurrency. +-- +-- > concurrentList (pure 2) "demo" $ props +-- > & foo +-- > & bar +-- > & baz +-- +-- The above example will run foo and bar concurrently, and once either of +-- those 2 properties finishes, will start running baz. +concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +concurrentList getn d (Props ps) = property d go `addChildren` ps + where + go = do + n <- liftIO getn + withCapabilities n $ + startworkers n =<< liftIO (newMVar ps) + startworkers n q + | n < 1 = return NoChange + | n == 1 = worker q NoChange + | otherwise = + worker q NoChange + `concurrentSatisfy` + startworkers (n-1) q + worker q r = do + v <- liftIO $ modifyMVar q $ \v -> case v of + [] -> return ([], Nothing) + (p:rest) -> return (rest, Just p) + case v of + Nothing -> return r + Just p -> do + hn <- asks hostName + r' <- actionMessageOn hn + (getDesc p) + (getSatisfy p) + worker q (r <> r') + +-- | Run an action with the number of capabiities increased as necessary to +-- allow running on the specified number of cores. +-- +-- Never increases the number of capabilities higher than the actual number +-- of processors. +withCapabilities :: Int -> Propellor a -> Propellor a +withCapabilities n a = bracket setup cleanup (const a) + where + setup = do + np <- liftIO getNumProcessors + let n' = min n np + c <- liftIO getNumCapabilities + when (n' > c) $ + liftIO $ setNumCapabilities n' + return c + cleanup = liftIO . setNumCapabilities + +-- | Running Propellor actions concurrently. +concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result +concurrentSatisfy a1 a2 = do + h <- ask + ((r1, w1), (r2, w2)) <- liftIO $ + runp a1 h `A.concurrently` runp a2 h + tell (w1 <> w2) + return (r1 <> r2) + where + runp a h = evalRWST (runWithHost (catchPropellor a)) h () diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-} + +-- | This module adds conductors to propellor. A conductor is a Host that +-- is responsible for running propellor on other hosts +-- +-- This eliminates the need to manually run propellor --spin to +-- update the conducted hosts, and can be used to orchestrate updates +-- to hosts. +-- +-- The conductor needs to be able to ssh to the hosts it conducts, +-- and run propellor, as root. To this end, +-- the `Propellor.Property.Ssh.knownHost` property is automatically +-- added to the conductor, so it knows the host keys of the relevant hosts. +-- Also, each conducted host is configured to let its conductor +-- ssh in as root, by automatically adding the +-- `Propellor.Property.Ssh.authorizedKeysFrom` property. +-- +-- It's left up to you to use `Propellor.Property.Ssh.userKeys` to +-- configure the ssh keys for the root user on conductor hosts, +-- and to use `Ssh.hostKeys` to configure the host keys for the +-- conducted hosts. +-- +-- For example, if you have some webservers and a dnsserver, +-- and want the master host to conduct all of them: +-- +-- > import Propellor +-- > import Propellor.Property.Conductor +-- > import qualified Propellor.Property.Ssh as Ssh +-- > import qualified Propellor.Property.Cron as Cron +-- > +-- > main = defaultMain (orchestrate hosts) +-- > +-- > hosts = +-- > [ master +-- > , dnsserver +-- > ] ++ webservers +-- > +-- > dnsserver = host "dns.example.com" +-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")] +-- > & ... +-- > +-- > webservers = +-- > [ host "www1.example.com" +-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")] +-- > & ... +-- > , ... +-- > ] +-- > +-- > master = host "master.example.com" +-- > & Ssh.userKeys (User "root") [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")] +-- > & conducts webservers +-- > `before` conducts dnsserver +-- > & Cron.runPropellor +-- +-- Notice that, in the above example, the the webservers are conducted +-- first. Only once the webservers have successfully been set up is the +-- dnsserver updated. This way, when adding a new web server, the dns +-- won't list it until it's ready. +-- +-- There can be multiple conductors, and conductors can conduct other +-- conductors if you need such a hierarchy. (Loops in the hierarchy, such +-- as a host conducting itself, are detected and automatically broken.) +-- +-- While it's allowed for a single host to be conducted by +-- multiple conductors, the results can be discordent. +-- Since only one propellor process can be run on a host at a time, +-- one of the conductors will fail to communicate with it. +-- +-- Note that a conductor can see all PrivData of the hosts it conducts. + +module Propellor.Property.Conductor ( + orchestrate, + Conductable(..), +) where + +import Propellor.Base +import Propellor.Container +import Propellor.Spin (spin') +import Propellor.PrivData.Paths +import Propellor.Types.Info +import qualified Propellor.Property.Ssh as Ssh + +import qualified Data.Set as S + +-- | Class of things that can be conducted. +-- +-- There are instances for single hosts, and for lists of hosts. +-- With a list, each listed host will be conducted in turn. Failure to conduct +-- one host does not prevent conducting subsequent hosts in the list, but +-- will be propagated as an overall failure of the property. +class Conductable c where + conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) + +instance Conductable Host where + conducts h = conductorFor h <!> notConductorFor h + +instance Conductable [Host] where + conducts hs = + propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) + <!> + propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs) + where + desc = cdesc $ unwords $ map hostName hs + +data Orchestra + = Conductor Host [Orchestra] + | Conducted Host + +instance Show Orchestra where + show (Conductor h l) = "Conductor " ++ hostName h ++ " (" ++ show l ++ ")" + show (Conducted h) = "Conducted " ++ hostName h + +fullOrchestra :: Orchestra -> Bool +fullOrchestra (Conductor _ _) = True +fullOrchestra (Conducted _) = False + +topHost :: Orchestra -> Host +topHost (Conducted h) = h +topHost (Conductor h _) = h + +allHosts :: Orchestra -> [Host] +allHosts (Conducted h) = [h] +allHosts (Conductor h l) = h : concatMap allHosts l + +-- Makes an Orchestra for the host, and any hosts it's conducting. +mkOrchestra :: Host -> Orchestra +mkOrchestra = fromJust . go S.empty + where + go seen h + | S.member (hostName h) seen = Nothing -- break loop + | otherwise = Just $ case fromInfo (hostInfo h) of + ConductorFor [] -> Conducted h + ConductorFor l -> + let seen' = S.insert (hostName h) seen + in Conductor h (mapMaybe (go seen') l) + +-- Combines the two orchestras, if there's a place, or places where they +-- can be grafted together. +combineOrchestras :: Orchestra -> Orchestra -> Maybe Orchestra +combineOrchestras a b = combineOrchestras' a b <|> combineOrchestras' b a + +combineOrchestras' :: Orchestra -> Orchestra -> Maybe Orchestra +combineOrchestras' (Conducted h) b + | sameHost h (topHost b) = Just b + | otherwise = Nothing +combineOrchestras' (Conductor h os) (Conductor h' os') + | sameHost h h' = Just $ Conductor h (concatMap combineos os') + where + combineos o = case mapMaybe (`combineOrchestras` o) os of + [] -> [o] + os'' -> os'' +combineOrchestras' a@(Conductor h _) (Conducted h') + | sameHost h h' = Just a +combineOrchestras' (Conductor h os) b + | null (catMaybes (map snd osgrafts)) = Nothing + | otherwise = Just $ Conductor h (map (uncurry fromMaybe) osgrafts) + where + osgrafts = zip os (map (`combineOrchestras` b) os) + +sameHost :: Host -> Host -> Bool +sameHost a b = hostName a == hostName b + +-- Removes any loops that may be present in the Orchestra involving +-- the passed Host. This is a matter of traversing the Orchestra +-- top-down, and removing all occurrances of the host after the first +-- one seen. +deloop :: Host -> Orchestra -> Orchestra +deloop _ (Conducted h) = Conducted h +deloop thehost (Conductor htop ostop) = Conductor htop $ + fst $ seekh [] ostop (sameHost htop thehost) + where + seekh l [] seen = (l, seen) + seekh l ((Conducted h) : rest) seen + | sameHost h thehost = + if seen + then seekh l rest seen + else seekh (Conducted h : l) rest True + | otherwise = seekh (Conducted h:l) rest seen + seekh l ((Conductor h os) : rest) seen + | sameHost h thehost = + if seen + then seekh l rest seen + else + let (os', _seen') = seekh [] os True + in seekh (Conductor h os' : l) rest True + | otherwise = + let (os', seen') = seekh [] os seen + in seekh (Conductor h os' : l) rest seen' + +-- Extracts the Orchestras from a list of hosts. +-- +-- Method: For each host that is a conductor, check the +-- list of orchesteras to see if any already contain that host, or +-- any of the hosts it conducts. If so, add the host to that +-- orchestra. If not, start a new orchestra. +-- +-- The result is a set of orchestras, which are each fully disconnected +-- from the other. Some may contain loops. +extractOrchestras :: [Host] -> [Orchestra] +extractOrchestras = filter fullOrchestra . go [] . map mkOrchestra + where + go os [] = os + go os (o:rest) = + let os' = zip os (map (combineOrchestras o) os) + in case catMaybes (map snd os') of + [] -> go (o:os) rest + [_] -> go (map (uncurry fromMaybe) os') rest + _ -> error "Bug: Host somehow ended up in multiple Orchestras!" + +-- | Pass this a list of all your hosts; it will finish setting up +-- orchestration as configured by the `conducts` properties you add to +-- hosts. +-- +-- > main = defaultMain $ orchestrate hosts +orchestrate :: [Host] -> [Host] +orchestrate hs = map go hs + where + go h + | isOrchestrated (fromInfo (hostInfo h)) = h + | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) + os = extractOrchestras hs + + removeold h = foldl removeold' h (oldconductorsof h) + removeold' h oldconductor = setContainerProps h $ containerProps h + ! conductedBy oldconductor + + oldconductors = zip hs (map (fromInfo . hostInfo) hs) + oldconductorsof h = flip mapMaybe oldconductors $ + \(oldconductor, NotConductorFor l) -> + if any (sameHost h) l + then Just oldconductor + else Nothing + +orchestrate' :: Host -> Orchestra -> Host +orchestrate' h (Conducted _) = h +orchestrate' h (Conductor c l) + | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l) + | any (sameHost h) (map topHost l) = cont $ + setContainerProps h $ containerProps h + & conductedBy c + | otherwise = cont h + where + cont h' = foldl orchestrate' h' l + +-- The host this property is added to becomes the conductor for the +-- specified Host. Note that `orchestrate` must be used for this property +-- to have any effect. +conductorFor :: Host -> Property (HasInfo + UnixLike) +conductorFor h = go + `setInfoProperty` (toInfo (ConductorFor [h])) + `requires` setupRevertableProperty (conductorKnownHost h) + `requires` Ssh.installed + where + desc = cdesc (hostName h) + + go :: Property UnixLike + go = property desc $ ifM (isOrchestrated <$> askInfo) + ( do + pm <- liftIO $ filterPrivData h + <$> readPrivDataFile privDataLocal + liftIO $ spin' (Just pm) Nothing (hostName h) h + -- Don't know if the spin made a change to + -- the remote host or not, but in any case, + -- the local host was not changed. + noChange + , do + warningMessage "Can't conduct; either orchestrate has not been used, or there is a conductor loop." + return FailedChange + ) + +-- Reverts conductorFor. +notConductorFor :: Host -> Property (HasInfo + UnixLike) +notConductorFor h = (doNothing :: Property UnixLike) + `setInfoProperty` (toInfo (NotConductorFor [h])) + `describe` desc + `requires` undoRevertableProperty (conductorKnownHost h) + where + desc = "not " ++ cdesc (hostName h) + +conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike +conductorKnownHost h = + mk Ssh.knownHost + <!> + mk Ssh.unknownHost + where + mk p = p [h] (hostName h) (User "root") + +-- Gives a conductor access to all the PrivData of the specified hosts. +-- This allows it to send it on the the hosts when conducting it. +-- +-- This is not done in conductorFor, so that it can be added +-- at the orchestration stage, and so is not added when there's a loop. +addConductorPrivData :: Host -> [Host] -> Host +addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } + where + i = mempty + `addInfo` mconcat (map privinfo hs) + `addInfo` Orchestrated (Any True) + privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h') + +-- Use this property to let the specified conductor ssh in and run propellor. +conductedBy :: Host -> RevertableProperty UnixLike UnixLike +conductedBy h = (setup <!> teardown) + `describe` ("conducted by " ++ hostName h) + where + setup = User "root" `Ssh.authorizedKeysFrom` (User "root", h) + `requires` Ssh.installed + teardown = User "root" `Ssh.unauthorizedKeysFrom` (User "root", h) + +cdesc :: String -> Desc +cdesc n = "conducting " ++ n + +-- A Host's Info indicates when it's a conductor for hosts, and when it's +-- stopped being a conductor. +newtype ConductorFor = ConductorFor [Host] + deriving (Typeable, Monoid) +newtype NotConductorFor = NotConductorFor [Host] + deriving (Typeable, Monoid) + +instance Show ConductorFor where + show (ConductorFor l) = "ConductorFor " ++ show (map hostName l) +instance Show NotConductorFor where + show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l) + +instance IsInfo ConductorFor where + propagateInfo _ = False +instance IsInfo NotConductorFor where + 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 + +isOrchestrated :: Orchestrated -> Bool +isOrchestrated (Orchestrated v) = getAny v diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs @@ -0,0 +1,116 @@ +module Propellor.Property.ConfFile ( + -- * Generic conffiles with sections + SectionStart, + SectionPast, + AdjustSection, + InsertSection, + adjustSection, + -- * Windows .ini files + IniSection, + IniKey, + containsIniSetting, + hasIniSection, + lacksIniSection, +) where + +import Propellor.Base +import Propellor.Property.File + +import Data.List (isPrefixOf, foldl') + +-- | find the line that is the start of the wanted section (eg, == "<Foo>") +type SectionStart = Line -> Bool +-- | find a line that indicates we are past the section +-- (eg, a new section header) +type SectionPast = Line -> Bool +-- | run on all lines in the section, including the SectionStart line; +-- can add, delete, and modify lines, or even delete entire section +type AdjustSection = [Line] -> [Line] +-- | if SectionStart does not find the section in the file, this is used to +-- insert the section somewhere within it +type InsertSection = [Line] -> [Line] + +-- | Adjusts a section of conffile. +adjustSection + :: Desc + -> SectionStart + -> SectionPast + -> AdjustSection + -> InsertSection + -> FilePath + -> Property UnixLike +adjustSection desc start past adjust insert = fileProperty desc go + where + go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls + in if null wanted + then insert ls + else pre ++ adjust wanted ++ post + find (pre, wanted, post) l + | null wanted && null post && (not . start) l = + (pre ++ [l], wanted, post) + | (start l && null wanted && null post) + || ((not . null) wanted && null post && (not . past) l) = + (pre, wanted ++ [l], post) + | otherwise = (pre, wanted, post ++ [l]) + +-- | Name of a section of an .ini file. This value is put +-- in square braces to generate the section header. +type IniSection = String + +-- | Name of a configuration setting within a .ini file. +type IniKey = String + +iniHeader :: IniSection -> String +iniHeader header = '[' : header ++ "]" + +adjustIniSection + :: Desc + -> IniSection + -> AdjustSection + -> InsertSection + -> FilePath + -> Property UnixLike +adjustIniSection desc header = + adjustSection + desc + (== iniHeader header) + ("[" `isPrefixOf`) + +-- | Ensures that a .ini file exists and contains a section +-- with a key=value setting. +containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike +containsIniSetting f (header, key, value) = adjustIniSection + (f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value) + header + go + (++ [confheader, confline]) -- add missing section at end + f + where + confheader = iniHeader header + confline = key ++ "=" ++ value + go [] = [confline] + go (l:ls) = if isKeyVal l then confline : ls else l : go ls + isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key] + +-- | 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 +hasIniSection f header keyvalues = adjustIniSection + ("set " ++ f ++ " section [" ++ header ++ "]") + header + go + (++ confheader : conflines) -- add missing section at end + f + where + confheader = iniHeader header + conflines = map (\(key, value) -> key ++ "=" ++ value) keyvalues + go _ = confheader : conflines + +-- | Ensures that a .ini file does not contain the specified section. +lacksIniSection :: FilePath -> IniSection -> Property UnixLike +lacksIniSection f header = adjustIniSection + (f ++ " lacks section [" ++ header ++ "]") + header + (const []) -- remove all lines of section + id -- add no lines if section is missing + f diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs @@ -0,0 +1,86 @@ +module Propellor.Property.Cron where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import Propellor.Bootstrap +import Utility.FileMode + +import Data.Char + +-- | When to run a cron job. +-- +-- The Daily, Monthly, and Weekly options allow the cron job to be run +-- by anacron, which is useful for non-servers. +data Times + = Times String -- ^ formatted as in crontab(5) + | Daily + | Weekly + | Monthly + +-- | Installs a cron job, that will run as a specified user in a particular +-- directory. Note that the Desc must be unique, as it is used for the +-- cron job filename. +-- +-- Only one instance of the cron job is allowed to run at a time, no matter +-- how long it runs. This is accomplished using flock locking of the cron +-- job file. +-- +-- The cron job's output will only be emailed if it exits nonzero. +job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike +job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props + & Apt.serviceInstalledRunning "cron" + & Apt.installed ["util-linux", "moreutils"] + & cronjobfile `File.hasContent` + [ case times of + Times _ -> "" + _ -> "#!/bin/sh\nset -e" + , "# Generated by propellor" + , "" + , "SHELL=/bin/sh" + , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" + , "" + , case times of + Times t -> t ++ "\t" ++ u ++ "\tchronic " ++ shellEscape scriptfile + _ -> case u of + "root" -> "chronic " ++ shellEscape scriptfile + _ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile + ] + & case times of + Times _ -> doNothing + _ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes) + -- Use a separate script because it makes the cron job name + -- prettier in emails, and also allows running the job manually. + & scriptfile `File.hasContent` + [ "#!/bin/sh" + , "# Generated by propellor" + , "set -e" + , "flock -n " ++ shellEscape cronjobfile + ++ " sh -c " ++ shellEscape cmdline + ] + & scriptfile `File.mode` combineModes (readModes ++ executeModes) + where + cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" + cronjobfile = "/etc" </> cronjobdir </> name + cronjobdir = case times of + Times _ -> "cron.d" + Daily -> "cron.daily" + Weekly -> "cron.weekly" + Monthly -> "cron.monthly" + scriptfile = "/usr/local/bin/" ++ name ++ "_cronjob" + name = map sanitize desc + sanitize c + | isAlphaNum c = c + | otherwise = '_' + +-- | Installs a cron job, and runs it niced and ioniced. +niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike +niceJob desc times user cddir command = job desc times user cddir + ("nice ionice -c 3 sh -c " ++ shellEscape command) + +-- | Installs a cron job to run propellor. +runPropellor :: Times -> Property UnixLike +runPropellor times = withOS "propellor cron job" $ \w o -> + ensureProperty w $ + niceJob "propellor" times (User "root") localdir + (bootstrapPropellorCommand o ++ "; ./propellor") diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs @@ -0,0 +1,156 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> + +module Propellor.Property.DebianMirror + ( DebianPriority (..) + , showPriority + , mirror + , RsyncExtra (..) + , Method (..) + , DebianMirror + , debianMirrorHostName + , debianMirrorSuites + , debianMirrorArchitectures + , debianMirrorSections + , debianMirrorSourceBool + , debianMirrorPriorities + , debianMirrorMethod + , debianMirrorKeyring + , debianMirrorRsyncExtra + , mkDebianMirror + ) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.User as User + +import Data.List + + +data DebianPriority = Essential | Required | Important | Standard | Optional | Extra + deriving (Show, Eq) + +showPriority :: DebianPriority -> String +showPriority Essential = "essential" +showPriority Required = "required" +showPriority Important = "important" +showPriority Standard = "standard" +showPriority Optional = "optional" +showPriority Extra = "extra" + +data RsyncExtra = Doc | Indices | Tools | Trace + deriving (Show, Eq) + +showRsyncExtra :: RsyncExtra -> String +showRsyncExtra Doc = "doc" +showRsyncExtra Indices = "indices" +showRsyncExtra Tools = "tools" +showRsyncExtra Trace = "trace" + +data Method = Ftp | Http | Https | Rsync | MirrorFile + +showMethod :: Method -> String +showMethod Ftp = "ftp" +showMethod Http = "http" +showMethod Https = "https" +showMethod Rsync = "rsync" +showMethod MirrorFile = "file" + +-- | To get a new DebianMirror and set options, use: +-- +-- > mkDebianMirror mymirrordir mycrontimes +-- > . debianMirrorHostName "otherhostname" +-- > . debianMirrorSourceBool True + +data DebianMirror = DebianMirror + { _debianMirrorHostName :: HostName + , _debianMirrorDir :: FilePath + , _debianMirrorSuites :: [DebianSuite] + , _debianMirrorArchitectures :: [Architecture] + , _debianMirrorSections :: [Apt.Section] + , _debianMirrorSourceBool :: Bool + , _debianMirrorPriorities :: [DebianPriority] + , _debianMirrorMethod :: Method + , _debianMirrorKeyring :: FilePath + , _debianMirrorRsyncExtra :: [RsyncExtra] + , _debianMirrorCronTimes :: Cron.Times + } + +mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror +mkDebianMirror dir crontimes = DebianMirror + { _debianMirrorHostName = "httpredir.debian.org" + , _debianMirrorDir = dir + , _debianMirrorSuites = [] + , _debianMirrorArchitectures = [] + , _debianMirrorSections = [] + , _debianMirrorSourceBool = False + , _debianMirrorPriorities = [] + , _debianMirrorMethod = Http + , _debianMirrorKeyring = "/usr/share/keyrings/debian-archive-keyring.gpg" + , _debianMirrorRsyncExtra = [Trace] + , _debianMirrorCronTimes = crontimes + } + +debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror +debianMirrorHostName hn m = m { _debianMirrorHostName = hn } + +debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror +debianMirrorSuites s m = m { _debianMirrorSuites = s } + +debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror +debianMirrorArchitectures a m = m { _debianMirrorArchitectures = a } + +debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror +debianMirrorSections s m = m { _debianMirrorSections = s } + +debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror +debianMirrorSourceBool s m = m { _debianMirrorSourceBool = s } + +debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror +debianMirrorPriorities p m = m { _debianMirrorPriorities = p } + +debianMirrorMethod :: Method -> DebianMirror -> DebianMirror +debianMirrorMethod me m = m { _debianMirrorMethod = me } + +debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror +debianMirrorKeyring k m = m { _debianMirrorKeyring = k } + +debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror +debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } + +mirror :: DebianMirror -> Property DebianLike +mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props + & Apt.installed ["debmirror"] + & User.accountFor (User "debmirror") + & File.dirExists dir + & File.ownerGroup dir (User "debmirror") (Group "debmirror") + & check (not . and <$> mapM suitemirrored suites) + (cmdProperty "debmirror" args) + `describe` "debmirror setup" + & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" + (unwords ("/usr/bin/debmirror" : args)) + where + dir = _debianMirrorDir mirror' + suites = _debianMirrorSuites mirror' + suitemirrored suite = doesDirectoryExist $ dir </> "dists" </> Apt.showSuite suite + architecturearg = intercalate "," + suitearg = intercalate "," $ map Apt.showSuite suites + priorityRegex pp = "(" ++ intercalate "|" (map showPriority pp) ++ ")" + rsyncextraarg [] = "none" + rsyncextraarg res = intercalate "," $ map showRsyncExtra res + args = + [ "--dist" , suitearg + , "--arch", architecturearg $ map architectureToDebianArchString (_debianMirrorArchitectures mirror') + , "--section", intercalate "," $ _debianMirrorSections mirror' + , "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\"" + ] + ++ + (if _debianMirrorSourceBool mirror' then [] else ["--nosource"]) + ++ + [ "--host", _debianMirrorHostName mirror' + , "--method", showMethod $ _debianMirrorMethod mirror' + , "--rsync-extra", rsyncextraarg $ _debianMirrorRsyncExtra mirror' + , "--keyring", _debianMirrorKeyring mirror' + , dir + ] diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs @@ -0,0 +1,246 @@ +module Propellor.Property.Debootstrap ( + Url, + DebootstrapConfig(..), + built, + built', + extractSuite, + installed, + sourceInstall, + programPath, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.Chroot.Util +import Utility.Path +import Utility.FileMode + +import Data.List +import Data.Char +import System.Posix.Directory +import System.Posix.Files + +type Url = String + +-- | A monoid for debootstrap configuration. +-- mempty is a default debootstrapped system. +data DebootstrapConfig + = DefaultConfig + | MinBase + | BuilddD + | DebootstrapParam String + | DebootstrapConfig :+ DebootstrapConfig + deriving (Show) + +instance Monoid DebootstrapConfig where + mempty = DefaultConfig + mappend = (:+) + +toParams :: DebootstrapConfig -> [CommandParam] +toParams DefaultConfig = [] +toParams MinBase = [Param "--variant=minbase"] +toParams BuilddD = [Param "--variant=buildd"] +toParams (DebootstrapParam p) = [Param p] +toParams (c1 :+ c2) = toParams c1 <> toParams c2 + +-- | Builds a chroot in the given directory using debootstrap. +-- +-- The System can be any OS and architecture that debootstrap +-- and the kernel support. +built :: FilePath -> System -> DebootstrapConfig -> Property Linux +built target system config = built' (setupRevertableProperty installed) target system config + +built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux +built' installprop target system@(System _ arch) config = + go `before` oldpermfix + where + go = check (unpopulated target <||> ispartial) setupprop + `requires` installprop + + setupprop :: Property Linux + setupprop = property ("debootstrapped " ++ target) $ liftIO $ do + createDirectoryIfMissing True target + suite <- case extractSuite system of + Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system + Just s -> pure s + let params = toParams config ++ + [ Param $ "--arch=" ++ architectureToDebianArchString arch + , Param suite + , Param target + ] + cmd <- fromMaybe "debootstrap" <$> programPath + de <- standardPathEnv + ifM (boolSystemEnv cmd params (Just de)) + ( return MadeChange + , return FailedChange + ) + + -- A failed debootstrap run will leave a debootstrap directory; + -- recover by deleting it and trying again. + ispartial = ifM (doesDirectoryExist (target </> "debootstrap")) + ( do + removeChroot target + return True + , return False + ) + + -- May want to remove this after some appropriate length of time, + -- as it's a workaround for chroots set up with too tight + -- permissions. + oldpermfix :: Property Linux + oldpermfix = property ("fixed old chroot file mode") $ do + liftIO $ modifyFileMode target $ + addModes [otherReadMode, otherExecuteMode] + return NoChange + +extractSuite :: System -> Maybe String +extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s +extractSuite (System (Buntish r) _) = Just r +extractSuite (System (FreeBSD _) _) = Nothing + +-- | Ensures debootstrap is installed. +-- +-- When necessary, falls back to installing debootstrap from source. +-- Note that installation from source is done by downloading the tarball +-- from a Debian mirror, with no cryptographic verification. +installed :: RevertableProperty Linux Linux +installed = install <!> remove + where + install = check (isNothing <$> programPath) $ + (aptinstall `pickOS` sourceInstall) + `describe` "debootstrap installed" + + remove = (aptremove `pickOS` sourceRemove) + `describe` "debootstrap removed" + + aptinstall = Apt.installed ["debootstrap"] + aptremove = Apt.removed ["debootstrap"] + +sourceInstall :: Property Linux +sourceInstall = go + `requires` perlInstalled + `requires` arInstalled + where + go :: Property Linux + go = property "debootstrap installed from source" (liftIO sourceInstall') + +perlInstalled :: Property Linux +perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ + liftIO $ toResult . isJust <$> firstM id + [ yumInstall "perl" + ] + +arInstalled :: Property Linux +arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ + liftIO $ toResult . isJust <$> firstM id + [ yumInstall "binutils" + ] + +yumInstall :: String -> IO Bool +yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p] + +sourceInstall' :: IO Result +sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do + let indexfile = tmpd </> "index.html" + unlessM (download baseurl indexfile) $ + errorMessage $ "Failed to download " ++ baseurl + urls <- sortBy (flip compare) -- highest version first + . filter ("debootstrap_" `isInfixOf`) + . filter (".tar." `isInfixOf`) + . extractUrls baseurl <$> + readFileStrictAnyEncoding indexfile + nukeFile indexfile + + tarfile <- case urls of + (tarurl:_) -> do + let f = tmpd </> takeFileName tarurl + unlessM (download tarurl f) $ + errorMessage $ "Failed to download " ++ tarurl + return f + _ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl + + createDirectoryIfMissing True localInstallDir + bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do + changeWorkingDirectory localInstallDir + unlessM (boolSystem "tar" [Param "xf", File tarfile]) $ + errorMessage "Failed to extract debootstrap tar file" + nukeFile tarfile + l <- dirContents "." + case l of + (subdir:[]) -> do + changeWorkingDirectory subdir + makeWrapperScript (localInstallDir </> subdir) + return MadeChange + _ -> errorMessage "debootstrap tar file did not contain exactly one directory" + +sourceRemove :: Property Linux +sourceRemove = property "debootstrap not installed from source" $ liftIO $ + ifM (doesDirectoryExist sourceInstallDir) + ( do + removeDirectoryRecursive sourceInstallDir + return MadeChange + , return NoChange + ) + +sourceInstallDir :: FilePath +sourceInstallDir = "/usr/local/propellor/debootstrap" + +wrapperScript :: FilePath +wrapperScript = sourceInstallDir </> "debootstrap.wrapper" + +-- | Finds debootstrap in PATH, but fall back to looking for the +-- wrapper script that is installed, outside the PATH, when debootstrap +-- is installed from source. +programPath :: IO (Maybe FilePath) +programPath = getM searchPath + [ "debootstrap" + , wrapperScript + ] + +makeWrapperScript :: FilePath -> IO () +makeWrapperScript dir = do + createDirectoryIfMissing True (takeDirectory wrapperScript) + writeFile wrapperScript $ unlines + [ "#!/bin/sh" + , "set -e" + , "DEBOOTSTRAP_DIR=" ++ dir + , "export DEBOOTSTRAP_DIR" + , dir </> "debootstrap" ++ " \"$@\"" + ] + modifyFileMode wrapperScript (addModes $ readModes ++ executeModes) + +localInstallDir :: FilePath +localInstallDir = "/usr/local/debootstrap" + +-- This http server directory listing is relied on to be fairly sane, +-- which is one reason why it's using a specific server and not a +-- round-robin address. +baseurl :: Url +baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/" + +download :: Url -> FilePath -> IO Bool +download url dest = anyM id + [ boolSystem "curl" [Param "-o", File dest, Param url] + , boolSystem "wget" [Param "-O", File dest, Param url] + ] + +-- Pretty hackish, but I don't want to pull in a whole html parser +-- or parsec dependency just for this. +-- +-- To simplify parsing, lower case everything. This is ok because +-- the filenames are all lower-case anyway. +extractUrls :: Url -> String -> [Url] +extractUrls base = collect [] . map toLower + where + collect l [] = l + collect l ('h':'r':'e':'f':'=':r) = case r of + ('"':r') -> findend l r' + _ -> findend l r + collect l (_:cs) = collect l cs + + findend l s = + let (u, r) = break (== '"') s + u' = if "http" `isPrefixOf` u + then u + else base </> u + in collect (u':l) r diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs @@ -0,0 +1,346 @@ +-- | Disk image generation. +-- +-- This module is designed to be imported unqualified. + +{-# LANGUAGE TypeFamilies #-} + +module Propellor.Property.DiskImage ( + -- * Partition specification + module Propellor.Property.DiskImage.PartSpec, + -- * Properties + DiskImage, + imageBuilt, + imageRebuilt, + imageBuiltFrom, + imageExists, + -- * Finalization + Finalization, + grubBooted, + Grub.BIOS(..), + noFinalization, +) where + +import Propellor.Base +import Propellor.Property.DiskImage.PartSpec +import Propellor.Property.Chroot (Chroot) +import Propellor.Property.Chroot.Util (removeChroot) +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.Container +import Utility.Path + +import Data.List (isPrefixOf, isInfixOf, sortBy) +import Data.Function (on) +import qualified Data.Map.Strict as M +import qualified Data.ByteString.Lazy as L +import System.Posix.Files + +type DiskImage = FilePath + +-- | Creates a bootable disk image. +-- +-- 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) +-- > ] +-- +-- 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. +-- +-- Note that the `Chroot.noServices` property is automatically added to the +-- chroot while the disk image is being built, which should prevent any +-- daemons that are included from being started on the system that is +-- building the disk image. +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) 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 = imageBuilt' True + +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux +imageBuilt' rebuild img mkchroot tabletype final partspec = + imageBuiltFrom img chrootdir tabletype final partspec + `requires` Chroot.provisioned chroot + `requires` (cleanrebuild <!> (doNothing :: Property UnixLike)) + `describe` desc + where + desc = "built disk image " ++ img + cleanrebuild :: Property Linux + cleanrebuild + | rebuild = property desc $ do + liftIO $ removeChroot chrootdir + return MadeChange + | otherwise = doNothing + chrootdir = img ++ ".chroot" + chroot = + let c = 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 + +-- | This property is automatically added to the chroot when building a +-- disk image. It cleans any caches of information that can be omitted; +-- eg the apt cache on Debian. +cachesCleaned :: Property UnixLike +cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) + where + 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 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 + liftIO $ unmountBelow chrootdir + szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize + <$> liftIO (dirSizes chrootdir) + let calcsz mnts = maybe defSz fudge . getMountSz szm mnts + -- tie the knot! + let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ + map (calcsz mnts) mnts + ensureProperty w $ + imageExists img (partTableSize parttable) + `before` + partitioned YesReallyDeleteDiskContents 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 + +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux +partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> + mconcat $ zipWith3 (go w) mnts mntopts devs + where + desc = "partitions populated from " ++ chrootdir + + go _ Nothing _ _ = noChange + go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) + (const $ liftIO $ umountLazy tmpdir) + $ \ismounted -> if ismounted + then ensureProperty w $ + syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir + else return FailedChange + + filtersfor mnt = + let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $ + filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m) + (catMaybes mnts) + in concatMap (\m -> + -- Include the child mount point, but exclude its contents. + [ Include (Pattern m) + , Exclude (filesUnder m) + -- Preserve any lost+found directory that mkfs made + , Protect (Pattern "lost+found") + ]) childmnts + +-- 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 tt l basesizes = (mounts, mountopts, parttable) + where + (mounts, mountopts, sizers) = unzip3 l + parttable = PartTable tt (zipWith id sizers basesizes) + +-- | Generates a map of the sizes of the contents of +-- every directory in a filesystem tree. +-- +-- (Hard links are counted multiple times for simplicity) +-- +-- Should be same values as du -bl +dirSizes :: FilePath -> IO (M.Map FilePath Integer) +dirSizes top = go M.empty top [top] + where + go m _ [] = return m + go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do + s <- getSymbolicLinkStatus i + let sz = fromIntegral (fileSize s) + if isDirectory s + then do + subm <- go M.empty i =<< dirContents i + let sz' = M.foldr' (+) sz + (M.filterWithKey (const . subdirof i) subm) + go (M.insertWith (+) i sz' (M.union m subm)) dir is + else go (M.insertWith (+) dir sz m) dir is + subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent + +getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize +getMountSz _ _ Nothing = Nothing +getMountSz szm l (Just mntpt) = + fmap (`reducePartSize` childsz) (M.lookup mntpt szm) + where + childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) + +-- | Ensures that a disk image file of the specified size exists. +-- +-- If the file doesn't exist, or is too small, creates a new one, full of 0's. +-- +-- 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 + ms <- catchMaybeIO $ getFileStatus img + case ms of + Just s + | toInteger (fileSize s) == toInteger sz -> return NoChange + | toInteger (fileSize s) > toInteger sz -> do + setFileSize img (fromInteger sz) + return MadeChange + _ -> do + L.writeFile img (L.replicate (fromIntegral sz) 0) + return MadeChange + +-- | A pair of properties. The first property is satisfied within the +-- chroot, and is typically used to download the boot loader. +-- +-- 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. +-- +-- It's ok if the second property leaves additional things mounted +-- in the partition tree. +type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) + +imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux +imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = + property' "disk image finalized" $ \w -> + withTmpDir "mnt" $ \top -> + go w top `finally` liftIO (unmountall top) + where + go w top = do + liftIO $ mountall top + liftIO $ writefstab top + liftIO $ allowservices top + ensureProperty w $ final top devs + + -- Ordered lexographically by mount point, so / comes before /usr + -- comes before /usr/local + orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))] + orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs) + + swaps = map (SwapPartition . partitionLoopDev . snd) $ + filter ((== LinuxSwap) . partFs . fst) $ + zip parts devs + + mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of + Nothing -> noop + Just p -> do + let mnt = top ++ p + createDirectoryIfMissing True mnt + unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $ + error $ "failed mounting " ++ mnt + + unmountall top = do + unmountBelow top + umountLazy top + + writefstab top = do + let fstab = top ++ "/etc/fstab" + old <- catchDefaultIO [] $ filter (not . unconfigured) . lines + <$> readFileStrict fstab + new <- genFstab (map (top ++) (catMaybes mnts)) + swaps (toSysDir top) + writeFile fstab $ unlines $ new ++ old + -- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM" + unconfigured s = "UNCONFIGURED" `isInfixOf` s + + allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d") + +noFinalization :: Finalization +noFinalization = (doNothing, \_ _ -> doNothing) + +-- | Makes grub be the boot loader of the disk image. +grubBooted :: Grub.BIOS -> Finalization +grubBooted bios = (Grub.installed' bios, boots) + 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!" + +isChild :: FilePath -> Maybe MountPoint -> Bool +isChild mntpt (Just d) + | d `equalFilePath` mntpt = False + | otherwise = mntpt `dirContains` d +isChild _ Nothing = False + +-- | From a location in a chroot (eg, /tmp/chroot/usr) to +-- the corresponding location inside (eg, /usr). +toSysDir :: FilePath -> FilePath -> FilePath +toSysDir chrootdir d = case makeRelative chrootdir d of + "." -> "/" + sysdir -> "/" ++ sysdir diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -0,0 +1,81 @@ +-- | Disk image partition specification and combinators. + +module Propellor.Property.DiskImage.PartSpec ( + module Propellor.Property.DiskImage.PartSpec, + Partition, + PartSize(..), + PartFlag(..), + TableType(..), + Fs(..), + MountPoint, +) where + +import Propellor.Base +import Propellor.Property.Parted +import Propellor.Property.Mount + +-- | 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 + +-- | Add 2% for filesystem overhead. Rationalle for picking 2%: +-- A filesystem with 1% overhead might just sneak by as acceptable. +-- Double that just in case. Add an additional 3 mb to deal with +-- non-scaling overhead of filesystems (eg, superblocks). +-- Add an additional 200 mb for temp files, journals, etc. +fudge :: PartSize -> PartSize +fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) + +-- | 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 @@ -0,0 +1,550 @@ +module Propellor.Property.Dns ( + module Propellor.Types.Dns, + primary, + signedPrimary, + secondary, + secondaryFor, + mkSOA, + writeZoneFile, + nextSerialNumber, + adjustSerialNumber, + serialNumberOffset, + WarningMessage, + genZone, +) where + +import Propellor.Base +import Propellor.Types.Dns +import Propellor.Types.Info +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Service as Service +import Propellor.Property.Scheduled +import Propellor.Property.DnsSec +import Utility.Applicative + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List + +-- | Primary dns server for a domain, using bind. +-- +-- Currently, this only configures bind to serve forward DNS, not reverse DNS. +-- +-- Most of the content of the zone file is configured by setting properties +-- of hosts. For example, +-- +-- > host "foo.example.com" +-- > & ipv4 "192.168.1.1" +-- > & alias "mail.exmaple.com" +-- +-- Will cause that hostmame and its alias to appear in the zone file, +-- with the configured IP address. +-- +-- Also, if a host has a ssh public key configured, a SSHFP record will +-- be automatically generated for it. +-- +-- The [(BindDomain, Record)] list can be used for additional records +-- that cannot be configured elsewhere. This often includes NS records, +-- TXT records and perhaps CNAMEs pointing at hosts that propellor does +-- not control. +-- +-- The primary server is configured to only allow zone transfers to +-- secondary dns servers. These are determined in two ways: +-- +-- 1. By looking at the properties of other hosts, to find hosts that +-- are configured as the secondary dns server. +-- +-- 2. By looking for NS Records in the passed list of records. +-- +-- In either case, the secondary dns server Host should have an ipv4 and/or +-- ipv6 property defined. +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike +primary hosts domain soa rs = setup <!> cleanup + where + setup = setupPrimary zonefile id hosts domain soa rs + `onChange` Service.reloaded "bind9" + cleanup = cleanupPrimary zonefile domain + `onChange` Service.reloaded "bind9" + + zonefile = "/etc/bind/propellor/db." ++ domain + +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike) +setupPrimary zonefile mknamedconffile hosts domain soa rs = + withwarnings baseprop + `requires` servingZones + where + hostmap = hostMap hosts + -- Known hosts with hostname located in the domain. + indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap + + (partialzone, zonewarnings) = genZone indomain hostmap domain soa + baseprop = primaryprop + `setInfoProperty` (toInfo (addNamedConf conf)) + primaryprop :: Property DebianLike + primaryprop = property ("dns primary for " ++ domain) $ do + sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) + let zone = partialzone + { zHosts = zHosts partialzone ++ rs ++ sshfps } + ifM (liftIO $ needupdate zone) + ( makeChange $ writeZoneFile zone zonefile + , noChange + ) + withwarnings p = adjustPropertySatisfy p $ \a -> do + mapM_ warningMessage $ zonewarnings ++ secondarywarnings + a + conf = NamedConf + { confDomain = domain + , confDnsServerType = Master + , confFile = mknamedconffile zonefile + , confMasters = [] + , confAllowTransfer = nub $ + concatMap (`hostAddresses` hosts) $ + secondaries ++ nssecondaries + , confLines = [] + } + secondaries = otherServers Secondary hosts domain + secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $ + filter (\h -> null (hostAddresses h hosts)) secondaries + nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords + rootRecords = map snd $ + filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs + needupdate zone = do + v <- readZonePropellorFile zonefile + return $ case v of + Nothing -> True + Just oldzone -> + -- compare everything except serial + let oldserial = sSerial (zSOA oldzone) + z = zone { zSOA = (zSOA zone) { sSerial = oldserial } } + in z /= oldzone || oldserial < sSerial (zSOA zone) + + +cleanupPrimary :: FilePath -> Domain -> Property DebianLike +cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ + go `requires` namedConfWritten + where + desc = "removed dns primary for " ++ domain + go :: Property DebianLike + go = property desc (makeChange $ removeZoneFile zonefile) + +-- | Primary dns server for a domain, secured with DNSSEC. +-- +-- This is like `primary`, except the resulting zone +-- file is signed. +-- The Zone Signing Key (ZSK) and Key Signing Key (KSK) +-- used in signing it are taken from the PrivData. +-- +-- As a side effect of signing the zone, a +-- </var/cache/bind/dsset-domain.> +-- file will be created. This file contains the DS records +-- which need to be communicated to your domain registrar +-- to make DNSSEC be used for your domain. Doing so is outside +-- the scope of propellor (currently). See for example the tutorial +-- <https://www.digitalocean.com/community/tutorials/how-to-setup-dnssec-on-an-authoritative-bind-dns-server--2> +-- +-- The 'Recurrance' controls how frequently the signature +-- should be regenerated, using a new random salt, to prevent +-- zone walking attacks. `Weekly Nothing` is a reasonable choice. +-- +-- To transition from 'primary' to 'signedPrimary', you can revert +-- the 'primary' property, and add this property. +-- +-- Note that DNSSEC zone files use a serial number based on the unix epoch. +-- This is different from the serial number used by 'primary', so if you +-- want to later disable DNSSEC you will need to adjust the serial number +-- passed to mkSOA to ensure it is larger. +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike +signedPrimary recurrance hosts domain soa rs = setup <!> cleanup + where + setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") + (props + & setupPrimary zonefile signedZoneFile hosts domain soa rs' + & zoneSigned domain zonefile + & forceZoneSigned domain zonefile `period` recurrance + ) + `onChange` Service.reloaded "bind9" + + cleanup = cleanupPrimary zonefile domain + `onChange` revert (zoneSigned domain zonefile) + `onChange` Service.reloaded "bind9" + + -- Include the public keys into the zone file. + rs' = include PubKSK : include PubZSK : rs + include k = (RootDomain, INCLUDE (keyFn domain k)) + + -- Put DNSSEC zone files in a different directory than is used for + -- the regular ones. This allows 'primary' to be reverted and + -- 'signedPrimary' enabled, without the reverted property stomping + -- on the new one's settings. + zonefile = "/etc/bind/propellor/dnssec/db." ++ domain + +-- | Secondary dns server for a domain. +-- +-- The primary server is determined by looking at the properties of other +-- hosts to find which one is configured as the primary. +-- +-- Note that if a host is declared to be a primary and a secondary dns +-- server for the same domain, the primary server config always wins. +secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike +secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain + +-- | This variant is useful if the primary server does not have its DNS +-- configured via propellor. +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike +secondaryFor masters hosts domain = setup <!> cleanup + where + setup = pureInfoProperty desc (addNamedConf conf) + `requires` servingZones + cleanup = namedConfWritten + + desc = "dns secondary for " ++ domain + conf = NamedConf + { confDomain = domain + , confDnsServerType = Secondary + , confFile = "db." ++ domain + , confMasters = concatMap (`hostAddresses` hosts) masters + , confAllowTransfer = [] + , confLines = [] + } + +otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] +otherServers wantedtype hosts domain = + M.keys $ M.filter wanted $ hostMap hosts + where + wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of + Nothing -> False + Just conf -> confDnsServerType conf == wantedtype + && confDomain conf == domain + +-- | Rewrites the whole named.conf.local file to serve the zones +-- configured by `primary` and `secondary`, and ensures that bind9 is +-- running. +servingZones :: Property DebianLike +servingZones = namedConfWritten + `onChange` Service.reloaded "bind9" + `requires` Apt.serviceInstalledRunning "bind9" + +namedConfWritten :: Property DebianLike +namedConfWritten = property' "named.conf configured" $ \w -> do + zs <- getNamedConf + ensureProperty w $ + hasContent namedConfFile $ + concatMap confStanza $ M.elems zs + +confStanza :: NamedConf -> [Line] +confStanza c = + [ "// automatically generated by propellor" + , "zone \"" ++ confDomain c ++ "\" {" + , cfgline "type" (if confDnsServerType c == Master then "master" else "slave") + , cfgline "file" ("\"" ++ confFile c ++ "\"") + ] ++ + mastersblock ++ + allowtransferblock ++ + (map (\l -> "\t" ++ l ++ ";") (confLines c)) ++ + [ "};" + , "" + ] + where + cfgline f v = "\t" ++ f ++ " " ++ v ++ ";" + ipblock name l = + [ "\t" ++ name ++ " {" ] ++ + (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++ + [ "\t};" ] + mastersblock + | null (confMasters c) = [] + | otherwise = ipblock "masters" (confMasters c) + -- an empty block prohibits any transfers + allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c) + +namedConfFile :: FilePath +namedConfFile = "/etc/bind/named.conf.local" + +-- | Generates a SOA with some fairly sane numbers in it. +-- +-- The Domain is the domain to use in the SOA record. Typically +-- something like ns1.example.com. So, not the domain that this is the SOA +-- record for. +-- +-- The SerialNumber can be whatever serial number was used by the domain +-- before propellor started managing it. Or 0 if the domain has only ever +-- been managed by propellor. +-- +-- You do not need to increment the SerialNumber when making changes! +-- Propellor will automatically add the number of commits in the git +-- repository to the SerialNumber. +mkSOA :: Domain -> SerialNumber -> SOA +mkSOA d sn = SOA + { sDomain = AbsDomain d + , sSerial = sn + , sRefresh = hours 4 + , sRetry = hours 1 + , sExpire = 2419200 -- 4 weeks + , sNegativeCacheTTL = hours 8 + } + where + hours n = n * 60 * 60 + +dValue :: BindDomain -> String +dValue (RelDomain d) = d +dValue (AbsDomain d) = d ++ "." +dValue (RootDomain) = "@" + +rField :: Record -> Maybe String +rField (Address (IPv4 _)) = Just "A" +rField (Address (IPv6 _)) = Just "AAAA" +rField (CNAME _) = Just "CNAME" +rField (MX _ _) = Just "MX" +rField (NS _) = Just "NS" +rField (TXT _) = Just "TXT" +rField (SRV _ _ _ _) = Just "SRV" +rField (SSHFP _ _ _) = Just "SSHFP" +rField (INCLUDE _) = Just "$INCLUDE" +rField (PTR _) = Nothing + +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 (NS d) = Just $ dValue d +rValue (SRV priority weight port target) = Just $ unwords + [ show priority + , show weight + , show port + , dValue target + ] +rValue (SSHFP x y s) = Just $ unwords + [ show x + , show y + , s + ] +rValue (INCLUDE f) = Just f +rValue (TXT s) = Just $ [q] ++ filter (/= q) s ++ [q] + where + q = '"' +rValue (PTR _) = Nothing + +-- | Adjusts the serial number of the zone to always be larger +-- than the serial number in the Zone record, +-- and always be larger than the passed SerialNumber. +nextSerialNumber :: Zone -> SerialNumber -> Zone +nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial + +adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone +adjustSerialNumber (Zone d soa l) f = Zone d soa' l + where + soa' = soa { sSerial = f (sSerial soa) } + +-- | Count the number of git commits made to the current branch. +serialNumberOffset :: IO SerialNumber +serialNumberOffset = fromIntegral . length . lines + <$> readProcess "git" ["log", "--pretty=%H"] + +-- | Write a Zone out to a to a file. +-- +-- The serial number in the Zone automatically has the serialNumberOffset +-- added to it. Also, just in case, the old serial number used in the zone +-- file is checked, and if it is somehow larger, its succ is used. +writeZoneFile :: Zone -> FilePath -> IO () +writeZoneFile z f = do + oldserial <- oldZoneFileSerialNumber f + offset <- serialNumberOffset + let z' = nextSerialNumber + (adjustSerialNumber z (+ offset)) + oldserial + createDirectoryIfMissing True (takeDirectory f) + writeFile f (genZoneFile z') + writeZonePropellorFile f z' + +removeZoneFile :: FilePath -> IO () +removeZoneFile f = do + nukeFile f + nukeFile (zonePropellorFile f) + +-- | Next to the zone file, is a ".propellor" file, which contains +-- the serialized Zone. This saves the bother of parsing +-- the horrible bind zone file format. +zonePropellorFile :: FilePath -> FilePath +zonePropellorFile f = f ++ ".propellor" + +oldZoneFileSerialNumber :: FilePath -> IO SerialNumber +oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile + +writeZonePropellorFile :: FilePath -> Zone -> IO () +writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z) + +readZonePropellorFile :: FilePath -> IO (Maybe Zone) +readZonePropellorFile f = catchDefaultIO Nothing $ + readish <$> readFileStrict (zonePropellorFile f) + +-- | Generating a zone file. +genZoneFile :: Zone -> String +genZoneFile (Zone zdomain soa rs) = unlines $ + header : genSOA soa ++ mapMaybe (genRecord zdomain) rs + where + header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit." + +genRecord :: Domain -> (BindDomain, Record) -> Maybe String +genRecord zdomain (domain, record) = case (rField record, rValue record) of + (Nothing, _) -> Nothing + (_, Nothing) -> Nothing + (Just rfield, Just rvalue) -> Just $ intercalate "\t" $ case record of + INCLUDE _ -> [ rfield, rvalue ] + _ -> + [ domainHost zdomain domain + , "IN" + , rfield + , rvalue + ] + +genSOA :: SOA -> [String] +genSOA soa = + -- "@ IN SOA ns1.example.com. root (" + [ intercalate "\t" + [ dValue RootDomain + , "IN" + , "SOA" + , dValue (sDomain soa) + , "root" + , "(" + ] + , headerline sSerial "Serial" + , headerline sRefresh "Refresh" + , headerline sRetry "Retry" + , headerline sExpire "Expire" + , headerline sNegativeCacheTTL "Negative Cache TTL" + , inheader ")" + ] + where + headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment + inheader l = "\t\t\t" ++ l + +-- | Comment line in a zone file. +com :: String -> String +com s = "; " ++ s + +type WarningMessage = String + +-- | Generates a Zone for a particular Domain from the DNS properies of all +-- hosts that propellor knows about that are in that Domain. +-- +-- Does not include SSHFP records. +genZone :: [Host] -> M.Map HostName Host -> Domain -> SOA -> (Zone, [WarningMessage]) +genZone inzdomain hostmap zdomain soa = + let (warnings, zhosts) = partitionEithers $ concatMap concat + [ map hostips inzdomain + , map hostrecords inzdomain + , map addcnames (M.elems hostmap) + ] + in (Zone zdomain soa (simplify zhosts), warnings) + where + -- Each host with a hostname located in the zdomain + -- should have 1 or more IPAddrs in its Info. + -- + -- If a host lacks any IPAddr, it's probably a misconfiguration, + -- so warn. + hostips :: Host -> [Either WarningMessage (BindDomain, Record)] + hostips h + | null l = [Left $ "no IP address defined for host " ++ hostName h] + | otherwise = map Right l + where + info = hostInfo h + l = zip (repeat $ AbsDomain $ hostName h) + (map Address $ getAddresses info) + + -- Any host, whether its hostname is in the zdomain or not, + -- may have cnames which are in the zdomain. The cname may even be + -- the same as the root of the zdomain, which is a nice way to + -- specify IP addresses for a SOA record. + -- + -- Add Records for those.. But not actually, usually, cnames! + -- Why not? Well, using cnames doesn't allow doing some things, + -- including MX and round robin DNS, and certianly CNAMES + -- shouldn't be used in SOA records. + -- + -- We typically know the host's IPAddrs anyway. + -- So we can just use the IPAddrs. + addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] + addcnames h = concatMap gen $ filter (inDomain zdomain) $ + mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info + where + info = hostInfo h + gen c = case getAddresses info of + [] -> [ret (CNAME c)] + l -> map (ret . Address) l + where + ret record = Right (c, record) + + -- Adds any other DNS records for a host located in the zdomain. + hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] + hostrecords h = map Right l + where + info = hostInfo h + l = zip (repeat $ AbsDomain $ hostName h) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) + + -- Simplifies the list of hosts. Remove duplicate entries. + -- Also, filter out any CHAMES where the same domain has an + -- IP address, since that's not legal. + simplify :: [(BindDomain, Record)] -> [(BindDomain, Record)] + simplify l = nub $ filter (not . dupcname ) l + where + dupcname (d, CNAME _) | any (matchingaddr d) l = True + dupcname _ = False + matchingaddr d (d', (Address _)) | d == d' = True + matchingaddr _ _ = False + +inDomain :: Domain -> BindDomain -> Bool +inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d +inDomain _ _ = False -- can't tell, so assume not + +-- | Gets the hostname of the second domain, relative to the first domain, +-- suitable for using in a zone file. +domainHost :: Domain -> BindDomain -> String +domainHost _ (RelDomain d) = d +domainHost _ RootDomain = "@" +domainHost base (AbsDomain d) + | dotbase `isSuffixOf` d = take (length d - length dotbase) d + | base == d = "@" + | otherwise = d + where + dotbase = '.':base + +addNamedConf :: NamedConf -> NamedConfMap +addNamedConf conf = NamedConfMap (M.singleton domain conf) + where + domain = confDomain conf + +getNamedConf :: Propellor (M.Map Domain NamedConf) +getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo + +-- | Generates SSHFP records for hosts in the domain (or with CNAMES +-- in the domain) that have configured ssh public keys. +-- +-- This is done using ssh-keygen, so sadly needs IO. +genSSHFP :: Domain -> Host -> Propellor [(BindDomain, Record)] +genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) + where + get = fromHost [h] hostname Ssh.getHostPubKey + gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty + mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) + (AbsDomain hostname : cnames) + cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info + hostname = hostName h + info = hostInfo h + +genSSHFP' :: String -> IO [Record] +genSSHFP' pubkey = withTmpFile "sshfp" $ \tmp tmph -> do + hPutStrLn tmph pubkey + hClose tmph + s <- catchDefaultIO "" $ + readProcess "ssh-keygen" ["-r", "dummy", "-f", tmp] + return $ mapMaybe (parse . words) $ lines s + where + parse ("dummy":"IN":"SSHFP":x:y:s:[]) = do + x' <- readish x + y' <- readish y + return $ SSHFP x' y' s + parse _ = Nothing diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs @@ -0,0 +1,122 @@ +module Propellor.Property.DnsSec where + +import Propellor.Base +import qualified Propellor.Property.File as File + +-- | Puts the DNSSEC key files in place from PrivData. +-- +-- signedPrimary uses this, so this property does not normally need to be +-- used directly. +keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike +keysInstalled domain = setup <!> cleanup + where + setup = propertyList "DNSSEC keys installed" $ toProps $ + map installkey keys + + cleanup = propertyList "DNSSEC keys removed" $ toProps $ + map (File.notPresent . keyFn domain) keys + + installkey k = writer (keysrc k) (keyFn domain k) (Context domain) + where + writer + | isPublic k = File.hasPrivContentExposedFrom + | otherwise = File.hasPrivContentFrom + + keys = [ PubZSK, PrivZSK, PubKSK, PrivKSK ] + + keysrc k = PrivDataSource (DnsSec k) $ unwords + [ "The file with extension" + , keyExt k + , "created by running:" + , if isZoneSigningKey k + then "dnssec-keygen -a RSASHA256 -b 2048 -n ZONE " ++ domain + else "dnssec-keygen -f KSK -a RSASHA256 -b 4096 -n ZONE " ++ domain + ] + +-- | Uses dnssec-signzone to sign a domain's zone file. +-- +-- signedPrimary uses this, so this property does not normally need to be +-- used directly. +zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike +zoneSigned domain zonefile = setup <!> cleanup + where + setup :: Property (HasInfo + UnixLike) + setup = check needupdate (forceZoneSigned domain zonefile) + `requires` keysInstalled domain + + cleanup :: Property UnixLike + cleanup = File.notPresent (signedZoneFile zonefile) + `before` File.notPresent dssetfile + `before` revert (keysInstalled domain) + + dssetfile = dir </> "-" ++ domain ++ "." + dir = takeDirectory zonefile + + -- Need to update the signed zone file if the zone file or + -- any of the keys have a newer timestamp. + needupdate = do + v <- catchMaybeIO $ getModificationTime (signedZoneFile zonefile) + case v of + Nothing -> return True + Just t1 -> anyM (newerthan t1) $ + zonefile : map (keyFn domain) [minBound..maxBound] + + newerthan t1 f = do + t2 <- getModificationTime f + return (t2 >= t1) + +forceZoneSigned :: Domain -> FilePath -> Property UnixLike +forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do + salt <- take 16 <$> saltSha1 + let p = proc "dnssec-signzone" + [ "-A" + , "-3", salt + -- The serial number needs to be increased each time the + -- zone is resigned, even if there are no other changes, + -- so that it will propagate to secondaries. So, use the + -- unixtime serial format. + , "-N", "unixtime" + , "-o", domain + , zonefile + -- the ordering of these key files does not matter + , keyFn domain PubZSK + , keyFn domain PubKSK + ] + -- Run in the same directory as the zonefile, so it will + -- write the dsset file there. + (_, _, _, h) <- createProcess $ + p { cwd = Just (takeDirectory zonefile) } + ifM (checkSuccessProcess h) + ( return MadeChange + , return FailedChange + ) + +saltSha1 :: IO String +saltSha1 = readProcess "sh" + [ "-c" + , "head -c 1024 /dev/urandom | sha1sum | cut -d ' ' -f 1" + ] + +-- | The file used for a given key. +keyFn :: Domain -> DnsSecKey -> FilePath +keyFn domain k = "/etc/bind/propellor/dnssec" </> concat + [ "K" ++ domain ++ "." + , if isZoneSigningKey k then "ZSK" else "KSK" + , keyExt k + ] + +-- | These are the extensions that dnssec-keygen looks for. +keyExt :: DnsSecKey -> String +keyExt k + | isPublic k = ".key" + | otherwise = ".private" + +isPublic :: DnsSecKey -> Bool +isPublic k = k `elem` [PubZSK, PubKSK] + +isZoneSigningKey :: DnsSecKey -> Bool +isZoneSigningKey k = k `elem` [PubZSK, PrivZSK] + +-- | dnssec-signzone makes a .signed file +signedZoneFile :: FilePath -> FilePath +signedZoneFile zonefile = zonefile ++ ".signed" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs @@ -0,0 +1,714 @@ +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} + +-- | Docker support for propellor +-- +-- The existance of a docker container is just another Property of a system, +-- which propellor can set up. See config.hs for an example. + +module Propellor.Property.Docker ( + -- * Host properties + installed, + configured, + container, + docked, + imageBuilt, + imagePulled, + memoryLimited, + garbageCollected, + tweaked, + Image(..), + latestImage, + ContainerName, + Container(..), + HasImage(..), + -- * Container configuration + dns, + hostname, + Publishable, + publish, + expose, + user, + Mountable, + volume, + volumes_from, + workdir, + memory, + cpuShares, + link, + environment, + ContainerAlias, + restartAlways, + restartOnFailure, + restartNever, + -- * Internal use + init, + chain, +) where + +import Propellor.Base hiding (init) +import Propellor.Types.Docker +import Propellor.Types.Container +import Propellor.Types.Core +import Propellor.Types.CmdLine +import Propellor.Types.Info +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.Shim as Shim +import Utility.Path +import Utility.ThreadScheduler + +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"] + +-- | Configures docker with an authentication file, so that images can be +-- pushed to index.docker.io. Optional. +configured :: Property (HasInfo + DebianLike) +configured = prop `requires` installed + where + prop :: Property (HasInfo + DebianLike) + prop = withPrivData src anyContext $ \getcfg -> + property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $ + "/root/.dockercfg" `File.hasContent` privDataLines cfg + src = PrivDataSourceFileFromCommand DockerAuthentication + "/root/.dockercfg" "docker login" + +-- | A short descriptive name for a container. +-- Should not contain whitespace or other unusual characters, +-- only [a-zA-Z0-9_-] are allowed +type ContainerName = String + +-- | A docker container. +data Container = Container Image Host + +instance IsContainer Container where + containerProperties (Container _ h) = containerProperties h + containerInfo (Container _ h) = containerInfo h + setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps) + +class HasImage a where + getImageName :: a -> Image + +instance HasImage Image where + getImageName = id + +instance HasImage Container where + getImageName (Container i _) = i + +-- | Defines a Container with a given name, image, and properties. +-- Add properties to configure the Container. +-- +-- > container "web-server" (latestImage "debian") $ props +-- > & publish "80:80" +-- > & Apt.installed {"apache2"] +-- > & ... +container :: ContainerName -> Image -> Props metatypes -> Container +container cn image (Props ps) = Container image (Host cn ps info) + where + info = dockerInfo mempty <> mconcat (map getInfoRecursive ps) + +-- | Ensures that a docker container is set up and running. +-- +-- The container has its own Properties which are handled by running +-- propellor inside the container. +-- +-- When the container's Properties include DNS info, such as a CNAME, +-- that is propagated to the Info of the Host it's docked in. +-- +-- Reverting this property ensures that the container is stopped and +-- removed. +docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +docked ctr@(Container _ h) = + (propagateContainerInfo ctr (go "docked" setup)) + <!> + (go "undocked" teardown) + where + cn = hostName h + + go desc a = property' (desc ++ " " ++ cn) $ \w -> do + hn <- asks hostName + let cid = ContainerId hn cn + ensureProperty w $ a cid (mkContainerInfo cid ctr) + + setup :: ContainerId -> ContainerInfo -> Property Linux + setup cid (ContainerInfo image runparams) = + provisionContainer cid + `requires` + runningContainer cid image runparams + `requires` + installed + + teardown :: ContainerId -> ContainerInfo -> Property Linux + teardown cid (ContainerInfo image _runparams) = + combineProperties ("undocked " ++ fromContainerId cid) $ toProps + [ stoppedContainer cid + , property ("cleaned up " ++ fromContainerId cid) $ + liftIO $ report <$> mapM id + [ removeContainer cid + , removeImage image + ] + ] + +-- | Build the image from a directory containing a Dockerfile. +imageBuilt :: HasImage c => FilePath -> c -> Property Linux +imageBuilt directory ctr = built `describe` msg + where + msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory + built :: Property Linux + built = tightenTargets $ + Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir + `assume` MadeChange + workDir p = p { cwd = Just directory } + image = getImageName ctr + +-- | Pull the image from the standard Docker Hub registry. +imagePulled :: HasImage c => c -> Property Linux +imagePulled ctr = pulled `describe` msg + where + msg = "docker image " ++ (imageIdentifier image) ++ " pulled" + pulled :: Property Linux + pulled = tightenTargets $ + Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] + `assume` MadeChange + image = getImageName ctr + +propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) +propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ + p `addInfoProperty` dockerinfo + where + dockerinfo = dockerInfo $ + mempty { _dockerContainers = M.singleton cn h } + cn = hostName h + +mkContainerInfo :: ContainerId -> Container -> ContainerInfo +mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = + ContainerInfo img runparams + where + runparams = map (\(DockerRunParam mkparam) -> mkparam hn) + (_dockerRunParams info) + info = fromInfo $ hostInfo h' + h' = setContainerProps h $ containerProps h + -- Restart by default so container comes up on + -- boot or when docker is upgraded. + &^ restartAlways + -- Expose propellor directory inside the container. + & volume (localdir++":"++localdir) + -- Name the container in a predictable way so we + -- and the user can easily find it later. This property + -- comes last, so it cannot be overridden. + & name (fromContainerId cid) + +-- | Causes *any* docker images that are not in use by running containers to +-- be deleted. And deletes any containers that propellor has set up +-- before that are not currently running. Does not delete any containers +-- that were not set up using propellor. +-- +-- Generally, should come after the properties for the desired containers. +garbageCollected :: Property Linux +garbageCollected = propertyList "docker garbage collected" $ props + & gccontainers + & gcimages + where + gccontainers :: Property Linux + gccontainers = property "docker containers garbage collected" $ + liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) + gcimages :: Property Linux + gcimages = property "docker images garbage collected" $ + liftIO $ report <$> (mapM removeImage =<< listImages) + +-- | Tweaks a container to work well with docker. +-- +-- Currently, this consists of making pam_loginuid lines optional in +-- the pam config, to work around <https://github.com/docker/docker/issues/5663> +-- which affects docker 1.2.0. +tweaked :: Property Linux +tweaked = tightenTargets $ cmdProperty "sh" + [ "-c" + , "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*" + ] + `assume` NoChange + `describe` "tweaked for docker" + +-- | Configures the kernel to respect docker memory limits. +-- +-- This assumes the system boots using grub 2. And that you don't need any +-- other GRUB_CMDLINE_LINUX_DEFAULT settings. +-- +-- Only takes effect after reboot. (Not automated.) +memoryLimited :: Property DebianLike +memoryLimited = tightenTargets $ + "/etc/default/grub" `File.containsLine` cfg + `describe` "docker memory limited" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) + where + cmdline = "cgroup_enable=memory swapaccount=1" + cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" + +data ContainerInfo = ContainerInfo Image [RunParam] + +-- | Parameters to pass to `docker run` when creating a container. +type RunParam = String + +-- | ImageID is an image identifier to perform action on images. An +-- ImageID can be the name of an container image, a UID, etc. +-- +-- It just encapsulates a String to avoid the definition of a String +-- instance of ImageIdentifier. +newtype ImageID = ImageID String + +-- | Used to perform Docker action on an image. +-- +-- Minimal complete definition: `imageIdentifier` +class ImageIdentifier i where + -- | For internal purposes only. + toImageID :: i -> ImageID + toImageID = ImageID . imageIdentifier + -- | A string that Docker can use as an image identifier. + imageIdentifier :: i -> String + +instance ImageIdentifier ImageID where + imageIdentifier (ImageID i) = i + toImageID = id + +-- | A docker image, that can be used to run a container. The user has +-- to specify a name and can provide an optional tag. +-- See <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention> +-- for more information. +data Image = Image + { repository :: String + , tag :: Maybe String + } + deriving (Eq, Read, Show) + +-- | Defines a Docker image without any tag. This is considered by +-- Docker as the latest image of the provided repository. +latestImage :: String -> Image +latestImage repo = Image repo Nothing + +instance ImageIdentifier Image where + -- | The format of the imageIdentifier of an `Image` is: + -- repository | repository:tag + imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i) + +-- | The UID of an image. This UID is generated by Docker. +newtype ImageUID = ImageUID String + +instance ImageIdentifier ImageUID where + imageIdentifier (ImageUID uid) = uid + +-- | Set custom dns server for container. +dns :: String -> Property (HasInfo + Linux) +dns = runProp "dns" + +-- | Set container host name. +hostname :: String -> Property (HasInfo + Linux) +hostname = runProp "hostname" + +-- | Set name of container. +name :: String -> Property (HasInfo + Linux) +name = runProp "name" + +class Publishable p where + toPublish :: p -> String + +instance Publishable (Bound Port) where + toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p) + +-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort +instance Publishable String where + toPublish = id + +-- | Publish a container's port to the host +publish :: Publishable p => p -> Property (HasInfo + Linux) +publish = runProp "publish" . toPublish + +-- | Expose a container's port without publishing it. +expose :: String -> Property (HasInfo + Linux) +expose = runProp "expose" + +-- | Username or UID for container. +user :: String -> Property (HasInfo + Linux) +user = runProp "user" + +class Mountable p where + toMount :: p -> String + +instance Mountable (Bound FilePath) where + toMount p = hostSide p ++ ":" ++ containerSide p + +-- | string format: [host-dir]:[container-dir]:[rw|ro] +-- +-- With just a directory, creates a volume in the container. +instance Mountable String where + toMount = id + +-- | Mount a volume +volume :: Mountable v => v -> Property (HasInfo + Linux) +volume = runProp "volume" . toMount + +-- | Mount a volume from the specified container into the current +-- container. +volumes_from :: ContainerName -> Property (HasInfo + Linux) +volumes_from cn = genProp "volumes-from" $ \hn -> + fromContainerId (ContainerId hn cn) + +-- | Work dir inside the container. +workdir :: String -> Property (HasInfo + Linux) +workdir = runProp "workdir" + +-- | Memory limit for container. +-- Format: <number><optional unit>, where unit = b, k, m or g +-- +-- Note: Only takes effect when the host has the memoryLimited property +-- enabled. +memory :: String -> Property (HasInfo + Linux) +memory = runProp "memory" + +-- | CPU shares (relative weight). +-- +-- By default, all containers run at the same priority, but you can tell +-- the kernel to give more CPU time to a container using this property. +cpuShares :: Int -> Property (HasInfo + Linux) +cpuShares = runProp "cpu-shares" . show + +-- | Link with another container on the same host. +link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux) +link linkwith calias = genProp "link" $ \hn -> + fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias + +-- | A short alias for a linked container. +-- Each container has its own alias namespace. +type ContainerAlias = String + +-- | This property is enabled by default for docker containers configured by +-- propellor; as well as keeping badly behaved containers running, +-- it ensures that containers get started back up after reboot or +-- after docker is upgraded. +restartAlways :: Property (HasInfo + Linux) +restartAlways = runProp "restart" "always" + +-- | Docker will restart the container if it exits nonzero. +-- If a number is provided, it will be restarted only up to that many +-- times. +restartOnFailure :: Maybe Int -> Property (HasInfo + Linux) +restartOnFailure Nothing = runProp "restart" "on-failure" +restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) + +-- | Makes docker not restart a container when it exits +-- Note that this includes not restarting it on boot! +restartNever :: Property (HasInfo + Linux) +restartNever = runProp "restart" "no" + +-- | Set environment variable with a tuple composed by the environment +-- variable name and its value. +environment :: (String, String) -> Property (HasInfo + Linux) +environment (k, v) = runProp "env" $ k ++ "=" ++ v + +-- | A container is identified by its name, and the host +-- on which it's deployed. +data ContainerId = ContainerId + { containerHostName :: HostName + , containerName :: ContainerName + } + deriving (Eq, Read, Show) + +-- | Two containers with the same ContainerIdent were started from +-- the same base image (possibly a different version though), and +-- with the same RunParams. +data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] + deriving (Read, Show, Eq) + +toContainerId :: String -> Maybe ContainerId +toContainerId s + | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of + (cn, hn) + | null hn || null cn -> Nothing + | otherwise -> Just $ ContainerId hn cn + | otherwise = Nothing + where + desuffix = reverse . drop len . reverse + len = length myContainerSuffix + +fromContainerId :: ContainerId -> String +fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix + +myContainerSuffix :: String +myContainerSuffix = ".propellor" + +containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i +containerDesc cid p = p `describe` desc + where + desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p + +runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux +runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do + l <- liftIO $ listContainers RunningContainers + if cid `elem` l + then checkident =<< liftIO getrunningident + else ifM (liftIO $ elem cid <$> listContainers AllContainers) + ( do + -- The container exists, but is not + -- running. Its parameters may have + -- changed, but we cannot tell without + -- starting it up first. + void $ liftIO $ startContainer cid + -- It can take a while for the container to + -- start up enough for its ident file to be + -- written, so retry for up to 60 seconds. + checkident =<< liftIO (retry 60 $ getrunningident) + , go image + ) + where + ident = ContainerIdent image hn cn runps + + -- Check if the ident has changed; if so the + -- parameters of the container differ and it must + -- be restarted. + checkident (Right runningident) + | runningident == Just ident = noChange + | otherwise = do + void $ liftIO $ stopContainer cid + restartcontainer + checkident (Left errmsg) = do + warningMessage errmsg + return FailedChange + + restartcontainer = do + oldimage <- liftIO $ + maybe (toImageID image) toImageID <$> commitContainer cid + void $ liftIO $ removeContainer cid + go oldimage + + getrunningident = withTmpFile "dockerrunsane" $ \t h -> do + -- detect #774376 which caused docker exec to not enter + -- the container namespace, and be able to access files + -- outside + hClose h + void . checkSuccessProcess . processHandle =<< + createProcess (inContainerProcess cid [] + ["rm", "-f", t]) + ifM (doesFileExist t) + ( Right . readish <$> + readProcess' (inContainerProcess cid [] + ["cat", propellorIdent]) + , return $ Left "docker exec failed to enter chroot properly (maybe an old kernel version?)" + ) + + retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a)) + retry 0 _ = return (Right Nothing) + retry n a = do + v <- a + case v of + Right Nothing -> do + threadDelaySeconds (Seconds 1) + retry (n-1) a + _ -> return v + + go :: ImageIdentifier i => i -> Propellor Result + go img = liftIO $ do + clearProvisionedFlag cid + createDirectoryIfMissing True (takeDirectory $ identFile cid) + shim <- Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid) + writeFile (identFile cid) (show ident) + toResult <$> runContainer img + (runps ++ ["-i", "-d", "-t"]) + [shim, "--continue", show (DockerInit (fromContainerId cid))] + +-- | Called when propellor is running inside a docker container. +-- The string should be the container's ContainerId. +-- +-- This process is effectively init inside the container. +-- It even needs to wait on zombie processes! +-- +-- In the foreground, run an interactive bash (or sh) shell, +-- so that the user can interact with it when attached to the container. +-- +-- When the system reboots, docker restarts the container, and this is run +-- again. So, to make the necessary services get started on boot, this needs +-- to provision the container then. However, if the container is already +-- being provisioned by the calling propellor, it would be redundant and +-- problimatic to also provisoon it here, when not booting up. +-- +-- The solution is a flag file. If the flag file exists, then the container +-- was already provisioned. So, it must be a reboot, and time to provision +-- again. If the flag file doesn't exist, don't provision here. +init :: String -> IO () +init s = case toContainerId s of + Nothing -> error $ "Invalid ContainerId: " ++ s + Just cid -> do + changeWorkingDirectory localdir + writeFile propellorIdent . show =<< readIdentFile cid + whenM (checkProvisionedFlag cid) $ do + let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) + unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $ + warningMessage "Boot provision failed!" + void $ async $ job reapzombies + job $ do + flushConcurrentOutput + void $ tryIO $ ifM (inPath "bash") + ( boolSystem "bash" [Param "-l"] + , boolSystem "/bin/sh" [] + ) + putStrLn "Container is still running. Press ^P^Q to detach." + where + job = forever . void . tryIO + reapzombies = void $ getAnyProcessStatus True False + +-- | Once a container is running, propellor can be run inside +-- it to provision it. +provisionContainer :: ContainerId -> Property Linux +provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do + let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) + let params = ["--continue", show $ toChain cid] + msgh <- getMessageHandle + let p = inContainerProcess cid + (if isConsole msgh then ["-it"] else []) + (shim : params) + r <- withHandle StdoutHandle createProcessSuccess p $ + processChainOutput + when (r /= FailedChange) $ + setProvisionedFlag cid + return r + +toChain :: ContainerId -> CmdLine +toChain cid = DockerChain (containerHostName cid) (fromContainerId cid) + +chain :: [Host] -> HostName -> String -> IO () +chain hostlist hn s = case toContainerId s of + Nothing -> errorMessage "bad container id" + Just cid -> case findHostNoAlias hostlist hn of + Nothing -> errorMessage ("cannot find host " ++ hn) + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of + Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) + Just h -> go cid h + where + go cid h = do + changeWorkingDirectory localdir + onlyProcess (provisioningLock cid) $ do + r <- runPropellor h $ ensureChildProperties $ hostProperties h + flushConcurrentOutput + putStrLn $ "\n" ++ show r + +stopContainer :: ContainerId -> IO Bool +stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] + +startContainer :: ContainerId -> IO Bool +startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] + +stoppedContainer :: ContainerId -> Property Linux +stoppedContainer cid = containerDesc cid $ property' desc $ \w -> + ifM (liftIO $ elem cid <$> listContainers RunningContainers) + ( liftIO cleanup `after` ensureProperty w stop + , return NoChange + ) + where + desc = "stopped" + stop :: Property Linux + stop = property desc $ liftIO $ toResult <$> stopContainer cid + cleanup = do + nukeFile $ identFile cid + removeDirectoryRecursive $ shimdir cid + clearProvisionedFlag cid + +removeContainer :: ContainerId -> IO Bool +removeContainer cid = catchBoolIO $ + snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing + +removeImage :: ImageIdentifier i => i -> IO Bool +removeImage image = catchBoolIO $ + snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing + +runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool +runContainer image ps cmd = boolSystem dockercmd $ map Param $ + "run" : (ps ++ (imageIdentifier image) : cmd) + +inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess +inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd) + +commitContainer :: ContainerId -> IO (Maybe ImageUID) +commitContainer cid = catchMaybeIO $ + ImageUID . takeWhile (/= '\n') + <$> readProcess dockercmd ["commit", fromContainerId cid] + +data ContainerFilter = RunningContainers | AllContainers + deriving (Eq) + +-- | Only lists propellor managed containers. +listContainers :: ContainerFilter -> IO [ContainerId] +listContainers status = + mapMaybe toContainerId . concatMap (split ",") + . mapMaybe (lastMaybe . words) . lines + <$> readProcess dockercmd ps + where + ps + | status == AllContainers = baseps ++ ["--all"] + | otherwise = baseps + baseps = ["ps", "--no-trunc"] + +listImages :: IO [ImageUID] +listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] + +runProp :: String -> RunParam -> Property (HasInfo + Linux) +runProp field val = tightenTargets $ pureInfoProperty (param) $ + mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } + where + param = field++"="++val + +genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux) +genProp field mkval = tightenTargets $ pureInfoProperty field $ + mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } + +dockerInfo :: DockerInfo -> Info +dockerInfo i = mempty `addInfo` i + +-- | The ContainerIdent of a container is written to +-- </.propellor-ident> inside it. This can be checked to see if +-- the container has the same ident later. +propellorIdent :: FilePath +propellorIdent = "/.propellor-ident" + +provisionedFlag :: ContainerId -> FilePath +provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned" + +clearProvisionedFlag :: ContainerId -> IO () +clearProvisionedFlag = nukeFile . provisionedFlag + +setProvisionedFlag :: ContainerId -> IO () +setProvisionedFlag cid = do + createDirectoryIfMissing True (takeDirectory (provisionedFlag cid)) + writeFile (provisionedFlag cid) "1" + +checkProvisionedFlag :: ContainerId -> IO Bool +checkProvisionedFlag = doesFileExist . provisionedFlag + +provisioningLock :: ContainerId -> FilePath +provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock" + +shimdir :: ContainerId -> FilePath +shimdir cid = "docker" </> fromContainerId cid ++ ".shim" + +identFile :: ContainerId -> FilePath +identFile cid = "docker" </> fromContainerId cid ++ ".ident" + +readIdentFile :: ContainerId -> IO ContainerIdent +readIdentFile cid = fromMaybe (error "bad ident in identFile") + . readish <$> readFile (identFile cid) + +dockercmd :: String +dockercmd = "docker" + +report :: [Bool] -> Result +report rmed + | or rmed = MadeChange + | otherwise = NoChange + diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs @@ -0,0 +1,30 @@ +module Propellor.Property.Fail2Ban where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import Propellor.Property.ConfFile + +installed :: Property DebianLike +installed = Apt.serviceInstalledRunning "fail2ban" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "fail2ban" + +type Jail = String + +-- | By default, fail2ban only enables the ssh jail, but many others +-- are available to be enabled, for example "postfix-sasl" +jailEnabled :: Jail -> Property DebianLike +jailEnabled name = jailConfigured name "enabled" "true" + `onChange` reloaded + +-- | Configures a jail. For example: +-- +-- > jailConfigured "sshd" "port" "2222" +jailConfigured :: Jail -> IniKey -> String -> Property UnixLike +jailConfigured name key value = + jailConfFile name `containsIniSetting` (name, key, value) + +jailConfFile :: Jail -> FilePath +jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf" diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Property.File where + +import Propellor.Base +import Utility.FileMode + +import qualified Data.ByteString.Lazy as L +import System.Posix.Files +import System.Exit + +type Line = String + +-- | Replaces all the content of a file. +hasContent :: FilePath -> [Line] -> Property UnixLike +f `hasContent` newcontent = fileProperty + ("replace " ++ f) + (\_oldcontent -> newcontent) f + +-- | Ensures that a line is present in a file, adding it to the end if not. +containsLine :: FilePath -> Line -> Property UnixLike +f `containsLine` l = f `containsLines` [l] + +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 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. +lacksLine :: FilePath -> Line -> Property UnixLike +f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f + +lacksLines :: FilePath -> [Line] -> Property UnixLike +f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f + +-- | Replaces all the content of a file, ensuring that its modes do not +-- allow it to be read or written by anyone other than the current user +hasContentProtected :: FilePath -> [Line] -> Property UnixLike +f `hasContentProtected` newcontent = fileProperty' ProtectedWrite + ("replace " ++ f) + (\_oldcontent -> newcontent) f + +-- | Ensures a file has contents that comes from PrivData. +-- +-- The file's permissions are preserved if the file already existed. +-- Otherwise, they're set to 600. +hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f + +-- | Like hasPrivContent, but allows specifying a source +-- for PrivData, rather than using `PrivDataSourceFile`. +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContentFrom = hasPrivContent' ProtectedWrite + +-- | Leaves the file at its default or current mode, +-- allowing "private" data to be read. +-- +-- Use with caution! +hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f + +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContentExposedFrom = hasPrivContent' NormalWrite + +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => FileWriteMode -> s -> FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContent' writemode source f context = + withPrivData source context $ \getcontent -> + property' desc $ \o -> getcontent $ \privcontent -> + ensureProperty o $ fileProperty' writemode desc + (\_oldcontent -> privDataByteString privcontent) f + where + desc = "privcontent " ++ f + +-- | 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' + ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f + where + desc = f ++ " is based on " ++ f' + +-- | Removes a file. Does not remove symlinks or non-plain-files. +notPresent :: FilePath -> Property UnixLike +notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ + makeChange $ nukeFile f + +-- | Ensures a directory exists. +dirExists :: FilePath -> Property UnixLike +dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ + makeChange $ createDirectoryIfMissing True d + +-- | The location that a symbolic link points to. +newtype LinkTarget = LinkTarget FilePath + +-- | Creates or atomically updates a symbolic link. +-- +-- Does not overwrite regular files or directories. +isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike +link `isSymlinkedTo` (LinkTarget target) = property desc $ + go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) + where + desc = link ++ " is symlinked to " ++ target + go (Right stat) = + if isSymbolicLink stat + then checkLink + else nonSymlinkExists + go (Left _) = makeChange $ createSymbolicLink target link + + nonSymlinkExists = do + warningMessage $ link ++ " exists and is not a symlink" + return FailedChange + checkLink = do + target' <- liftIO $ readSymbolicLink link + if target == target' + then noChange + else makeChange updateLink + updateLink = createSymbolicLink target `viaStableTmp` link + +-- | 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') + where + desc = f ++ " is copy of " ++ f' + go (Right stat) = if isRegularFile stat + then gocmp =<< (liftIO $ cmp) + else warningMessage (f' ++ " 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'] + 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" + [Param "--preserve=all", Param "--", File src, File dest] + +-- | Ensures that a file/dir has the specified owner and group. +ownerGroup :: FilePath -> User -> Group -> Property UnixLike +ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og) + where + p = cmdProperty "chown" [og, f] + `changesFile` f + og = owner ++ ":" ++ group + +-- | Ensures that a file/dir has the specfied mode. +mode :: FilePath -> FileMode -> Property UnixLike +mode f v = p `changesFile` f + where + p = property (f ++ " mode " ++ show v) $ do + liftIO $ modifyFileMode f (const v) + return NoChange + +class FileContent c where + emptyFileContent :: c + readFileContent :: FilePath -> IO c + writeFileContent :: FileWriteMode -> FilePath -> c -> IO () + +data FileWriteMode = NormalWrite | ProtectedWrite + +instance FileContent [Line] where + emptyFileContent = [] + readFileContent f = lines <$> readFile f + writeFileContent NormalWrite f ls = writeFile f (unlines ls) + writeFileContent ProtectedWrite f ls = writeFileProtected f (unlines ls) + +instance FileContent L.ByteString where + emptyFileContent = L.empty + readFileContent = L.readFile + writeFileContent NormalWrite f c = L.writeFile f c + writeFileContent ProtectedWrite f c = + writeFileProtected' f (`L.hPutStr` c) + +-- | A property that applies a pure function to the content of a file. +fileProperty :: (FileContent c, Eq c) => Desc -> (c -> c) -> FilePath -> Property UnixLike +fileProperty = fileProperty' NormalWrite +fileProperty' :: (FileContent c, Eq c) => FileWriteMode -> Desc -> (c -> c) -> FilePath -> Property UnixLike +fileProperty' writemode desc a f = property desc $ go =<< liftIO (doesFileExist f) + where + go True = do + old <- liftIO $ readFileContent f + let new = a old + if old == new + then noChange + else makeChange $ updatefile new `viaStableTmp` f + go False = makeChange $ writer f (a emptyFileContent) + + -- Replicate the original file's owner and mode. + updatefile content dest = do + writer dest content + s <- getFileStatus f + setFileMode dest (fileMode s) + setOwnerAndGroup dest (fileOwner s) (fileGroup s) + + writer = writeFileContent writemode + +-- | A temp file to use when writing new content for a file. +-- +-- This is a stable name so it can be removed idempotently. +-- +-- It ends with "~" so that programs that read many config files from a +-- directory will treat it as an editor backup file, and not read it. +stableTmpFor :: FilePath -> FilePath +stableTmpFor f = f ++ ".propellor-new~" + +-- | Creates/updates a file atomically, running the action to create the +-- stable tmp file, and then renaming it into place. +viaStableTmp :: (MonadMask m, MonadIO m) => (FilePath -> m ()) -> FilePath -> m () +viaStableTmp a f = bracketIO setup cleanup go + where + setup = do + createDirectoryIfMissing True (takeDirectory f) + let tmpfile = stableTmpFor f + nukeFile tmpfile + return tmpfile + cleanup tmpfile = tryIO $ removeFile tmpfile + go tmpfile = do + a tmpfile + liftIO $ rename tmpfile f diff --git a/src/Propellor/Property/Firejail.hs b/src/Propellor/Property/Firejail.hs @@ -0,0 +1,31 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.Firejail ( + installed, + jailed, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File + +-- | Ensures that Firejail is installed +installed :: Property DebianLike +installed = Apt.installed ["firejail"] + +-- | For each program name passed, create symlinks in /usr/local/bin that +-- will launch that program in a Firejail sandbox. +-- +-- The profile for the sandbox will be the same as if the user had run +-- @firejail@ directly without passing @--profile@ (see "SECURITY PROFILES" in +-- firejail(1)). +-- +-- See "DESKTOP INTEGRATION" in firejail(1). +jailed :: [String] -> Property DebianLike +jailed ps = (jailed' `applyToList` ps) + `requires` installed + `describe` unwords ("firejail jailed":ps) + +jailed' :: String -> Property UnixLike +jailed' p = ("/usr/local/bin" </> p) + `File.isSymlinkedTo` File.LinkTarget "/usr/bin/firejail" diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs @@ -0,0 +1,205 @@ +-- | Maintainer: Arnaud Bailly <arnaud.oqube@gmail.com> +-- +-- Properties for configuring firewall (iptables) rules + +module Propellor.Property.Firewall ( + rule, + installed, + Chain(..), + Table(..), + Target(..), + Proto(..), + Rules(..), + ConnectionState(..), + ICMPTypeMatch(..), + TCPFlag(..), + Frequency(..), + IPWithMask(..), + fromIPWithMask +) where + +import Data.Monoid +import Data.Char +import Data.List + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Network as Network + +installed :: Property DebianLike +installed = Apt.installed ["iptables"] + +rule :: Chain -> Table -> Target -> Rules -> Property Linux +rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable + where + r = Rule c tb tg rs + addIpTable = liftIO $ do + let args = toIpTable r + exist <- boolSystem "iptables" (chk args) + if exist + then return NoChange + else toResult <$> boolSystem "iptables" (add args) + add params = Param "-A" : params + chk params = Param "-C" : params + +toIpTable :: Rule -> [CommandParam] +toIpTable r = map Param $ + fromChain (ruleChain r) : + toIpTableArg (ruleRules r) ++ + ["-t", fromTable (ruleTable r), "-j", fromTarget (ruleTarget r)] + +toIpTableArg :: Rules -> [String] +toIpTableArg Everything = [] +toIpTableArg (Proto proto) = ["-p", map toLower $ show proto] +toIpTableArg (DPort port) = ["--dport", fromPort port] +toIpTableArg (DPortRange (portf, portt)) = + ["--dport", fromPort portf ++ ":" ++ fromPort portt] +toIpTableArg (InIFace iface) = ["-i", iface] +toIpTableArg (OutIFace iface) = ["-o", iface] +toIpTableArg (Ctstate states) = + [ "-m" + , "conntrack" + , "--ctstate", intercalate "," (map show states) + ] +toIpTableArg (ICMPType i) = + [ "-m" + , "icmp" + , "--icmp-type", fromICMPTypeMatch i + ] +toIpTableArg (RateLimit f) = + [ "-m" + , "limit" + , "--limit", fromFrequency f + ] +toIpTableArg (TCPFlags m c) = + [ "-m" + , "tcp" + , "--tcp-flags" + , intercalate "," (map show m) + , intercalate "," (map show c) + ] +toIpTableArg TCPSyn = ["--syn"] +toIpTableArg (GroupOwner (Group g)) = + [ "-m" + , "owner" + , "--gid-owner" + , g + ] +toIpTableArg (Source ipwm) = + [ "-s" + , intercalate "," (map fromIPWithMask ipwm) + ] +toIpTableArg (Destination ipwm) = + [ "-d" + , intercalate "," (map fromIPWithMask ipwm) + ] +toIpTableArg (NotDestination ipwm) = + [ "!" + , "-d" + , intercalate "," (map fromIPWithMask ipwm) + ] +toIpTableArg (NatDestination ip mport) = + [ "--to-destination" + , fromIPAddr ip ++ maybe "" (\p -> ":" ++ fromPort 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 + +data Rule = Rule + { ruleChain :: Chain + , ruleTable :: Table + , ruleTarget :: Target + , ruleRules :: Rules + } deriving (Eq, Show) + +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" + +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 + +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 + +data Proto = TCP | UDP | ICMP + deriving (Eq, Show) + +data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID + deriving (Eq, Show) + +data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int + deriving (Eq, Show) + +fromICMPTypeMatch :: ICMPTypeMatch -> String +fromICMPTypeMatch (ICMPTypeName t) = t +fromICMPTypeMatch (ICMPTypeCode c) = show c + +data Frequency = NumBySecond Int + deriving (Eq, Show) + +fromFrequency :: Frequency -> String +fromFrequency (NumBySecond n) = show n ++ "/second" + +type TCPFlagMask = [TCPFlag] + +type TCPFlagComp = [TCPFlag] + +data TCPFlag = SYN | ACK | FIN | RST | URG | PSH | ALL | NONE + deriving (Eq, Show) + +data Rules + = Everything + | Proto Proto + -- ^There is actually some order dependency between proto and port so this should be a specific + -- data type with proto + ports + | DPort Port + | DPortRange (Port, Port) + | InIFace Network.Interface + | OutIFace Network.Interface + | Ctstate [ ConnectionState ] + | ICMPType ICMPTypeMatch + | RateLimit Frequency + | TCPFlags TCPFlagMask TCPFlagComp + | TCPSyn + | GroupOwner Group + | Source [ IPWithMask ] + | Destination [ IPWithMask ] + | NotDestination [ IPWithMask ] + | NatDestination IPAddr (Maybe Port) + | Rules :- Rules -- ^Combine two rules + deriving (Eq, Show) + +infixl 0 :- + +instance Monoid Rules where + mempty = Everything + mappend = (:-) diff --git a/src/Propellor/Property/FreeBSD.hs b/src/Propellor/Property/FreeBSD.hs @@ -0,0 +1,13 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- FreeBSD Properties +-- +-- This module is designed to be imported unqualified. + +module Propellor.Property.FreeBSD ( + module Propellor.Property.FreeBSD.Pkg, + module Propellor.Property.FreeBSD.Poudriere +) where + +import Propellor.Property.FreeBSD.Pkg +import Propellor.Property.FreeBSD.Poudriere diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -0,0 +1,88 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- FreeBSD pkgng properties + +{-# Language ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Propellor.Property.FreeBSD.Pkg where + +import Propellor.Base +import Propellor.Types.Info + +noninteractiveEnv :: [([Char], [Char])] +noninteractiveEnv = [("ASSUME_ALWAYS_YES", "yes")] + +pkgCommand :: String -> [String] -> (String, [String]) +pkgCommand cmd args = ("pkg", (cmd:args)) + +runPkg :: String -> [String] -> IO [String] +runPkg cmd args = + let + (p, a) = pkgCommand cmd args + in + lines <$> readProcess p a + +pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD +pkgCmdProperty cmd args = tightenTargets $ + let + (p, a) = pkgCommand cmd args + in + cmdPropertyEnv p a noninteractiveEnv + +pkgCmd :: String -> [String] -> IO [String] +pkgCmd cmd args = + let + (p, a) = pkgCommand cmd args + in + lines <$> readProcessEnv p a (Just noninteractiveEnv) + +newtype PkgUpdate = PkgUpdate String + deriving (Typeable, Monoid, Show) +instance IsInfo PkgUpdate where + propagateInfo _ = False + +pkgUpdated :: PkgUpdate -> Bool +pkgUpdated (PkgUpdate _) = True + +update :: Property (HasInfo + FreeBSD) +update = + let + upd = pkgCmd "update" [] + go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) + in + (property "pkg update has run" go :: Property FreeBSD) + `setInfoProperty` (toInfo (PkgUpdate "")) + +newtype PkgUpgrade = PkgUpgrade String + deriving (Typeable, Monoid, Show) +instance IsInfo PkgUpgrade where + propagateInfo _ = False + +pkgUpgraded :: PkgUpgrade -> Bool +pkgUpgraded (PkgUpgrade _) = True + +upgrade :: Property (HasInfo + FreeBSD) +upgrade = + let + upd = pkgCmd "upgrade" [] + go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) + in + (property "pkg upgrade has run" go :: Property FreeBSD) + `setInfoProperty` (toInfo (PkgUpdate "")) + `requires` update + +type Package = String + +installed :: Package -> Property FreeBSD +installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg] + +isInstallable :: Package -> IO Bool +isInstallable p = (not <$> isInstalled p) <&&> exists p + +isInstalled :: Package -> IO Bool +isInstalled p = (runPkg "info" [p] >> return True) + `catchIO` (\_ -> return False) + +exists :: Package -> IO Bool +exists p = (runPkg "search" ["--search", "name", "--exact", p] >> return True) + `catchIO` (\_ -> return False) diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs @@ -0,0 +1,143 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- FreeBSD Poudriere properties + +{-# Language GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Propellor.Property.FreeBSD.Poudriere where + +import Propellor.Base +import Propellor.Types.Info +import Data.List + +import qualified Propellor.Property.FreeBSD.Pkg as Pkg +import qualified Propellor.Property.ZFS as ZFS +import qualified Propellor.Property.File as File + +poudriereConfigPath :: FilePath +poudriereConfigPath = "/usr/local/etc/poudriere.conf" + +newtype PoudriereConfigured = PoudriereConfigured String + deriving (Typeable, Monoid, Show) +instance IsInfo PoudriereConfigured where + propagateInfo _ = False + +poudriereConfigured :: PoudriereConfigured -> Bool +poudriereConfigured (PoudriereConfigured _) = True + +setConfigured :: Property (HasInfo + FreeBSD) +setConfigured = tightenTargets $ + pureInfoProperty "Poudriere Configured" (PoudriereConfigured "") + +poudriere :: Poudriere -> Property (HasInfo + FreeBSD) +poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop + `requires` Pkg.installed "poudriere" + `before` setConfigured + where + confProp :: Property FreeBSD + confProp = tightenTargets $ + File.containsLines poudriereConfigPath (toLines conf) + setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS" + prop :: Property FreeBSD + prop + | isJust zfs = ((setZfs $ fromJust zfs) `before` confProp) + | otherwise = confProp `describe` "Configuring Poudriere without ZFS" + +poudriereCommand :: String -> [String] -> (String, [String]) +poudriereCommand cmd args = ("poudriere", cmd:args) + +runPoudriere :: String -> [String] -> IO [String] +runPoudriere cmd args = + let + (p, a) = poudriereCommand cmd args + in + lines <$> readProcess p a + +listJails :: IO [String] +listJails = mapMaybe (headMaybe . take 1 . words) + <$> runPoudriere "jail" ["-l", "-q"] + +jailExists :: Jail -> IO Bool +jailExists (Jail name _ _) = isInfixOf [name] <$> listJails + +jail :: Jail -> Property FreeBSD +jail j@(Jail name version arch) = tightenTargets $ + let + chk = do + c <- poudriereConfigured <$> askInfo + nx <- liftIO $ not <$> jailExists j + return $ c && nx + + (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version] + createJail = cmdProperty cmd args + in + check chk createJail + `describe` unwords ["Create poudriere jail", name] + +data JailInfo = JailInfo String + +data Poudriere = Poudriere + { _resolvConf :: String + , _freebsdHost :: String + , _baseFs :: String + , _usePortLint :: Bool + , _distFilesCache :: FilePath + , _svnHost :: String + , _zfs :: Maybe PoudriereZFS + } + +defaultConfig :: Poudriere +defaultConfig = Poudriere + "/etc/resolv.conf" + "ftp://ftp5.us.FreeBSD.org" + "/usr/local/poudriere" + True + "/usr/ports/distfiles" + "svn.freebsd.org" + Nothing + +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" + +fromArchitecture :: Architecture -> PoudriereArch +fromArchitecture X86_64 = AMD64 +fromArchitecture X86_32 = I386 +fromArchitecture _ = error "Not a valid Poudriere architecture." + +yesNoProp :: Bool -> String +yesNoProp b = if b then "yes" else "no" + +instance ToShellConfigLines Poudriere where + toAssoc c = map (\(k, f) -> (k, f c)) + [ ("RESOLV_CONF", _resolvConf) + , ("FREEBSD_HOST", _freebsdHost) + , ("BASEFS", _baseFs) + , ("USE_PORTLINT", yesNoProp . _usePortLint) + , ("DISTFILES_CACHE", _distFilesCache) + , ("SVN_HOST", _svnHost) + ] ++ maybe [ ("NO_ZFS", "yes") ] toAssoc (_zfs c) + +instance ToShellConfigLines PoudriereZFS where + toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) = + [ ("NO_ZFS", "no") + , ("ZPOOL", pool) + , ("ZROOTFS", show dataset) + ] + +type ConfigLine = String +type ConfigFile = [ConfigLine] + +class ToShellConfigLines a where + toAssoc :: a -> [(String, String)] + + toLines :: a -> [ConfigLine] + toLines c = map (\(k, v) -> intercalate "=" [k, v]) (toAssoc c) + +confFile :: FilePath +confFile = "/usr/local/etc/poudriere.conf" diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs @@ -0,0 +1,111 @@ +module Propellor.Property.Fstab ( + FsType, + Source, + MountPoint, + MountOpts(..), + module Propellor.Property.Fstab, +) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import Propellor.Property.Mount + +import Data.Char +import Data.List +import Utility.Table + +-- | Ensures that </etc/fstab> contains a line mounting the specified +-- `Source` on the specified `MountPoint`, and that it's currently mounted. +-- +-- For example: +-- +-- > mounted "auto" "/dev/sdb1" "/srv" mempty +-- +-- 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") + `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] + +newtype SwapPartition = SwapPartition FilePath + +-- | Replaces </etc/fstab> with a file that should cause the currently +-- mounted partitions to be re-mounted the same way on boot. +-- +-- For each specified MountPoint, the UUID of each partition +-- (or if there is no UUID, its label), its filesystem type, +-- and its mount options are all automatically probed. +-- +-- The SwapPartitions are also included in the generated fstab. +fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux +fstabbed mnts swaps = property' "fstabbed" $ \o -> do + fstab <- liftIO $ genFstab mnts swaps id + ensureProperty o $ + "/etc/fstab" `File.hasContent` fstab + +genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String] +genFstab mnts swaps mnttransform = do + fstab <- liftIO $ mapM getcfg (sort mnts) + swapfstab <- liftIO $ mapM getswapcfg swaps + return $ header ++ formatTable (legend : fstab ++ swapfstab) + where + header = + [ "# /etc/fstab: static file system information. See fstab(5)" + , "# " + ] + legend = ["# <file system>", "<mount point>", "<type>", "<options>", "<dump>", "<pass>"] + getcfg mnt = sequence + [ fromMaybe (error $ "unable to find mount source for " ++ mnt) + <$> getM (\a -> a mnt) + [ uuidprefix getMountUUID + , sourceprefix getMountLabel + , getMountSource + ] + , pure (mnttransform mnt) + , fromMaybe "auto" <$> getFsType mnt + , formatMountOpts <$> getFsMountOpts mnt + , pure "0" + , pure (if mnt == "/" then "1" else "2") + ] + getswapcfg (SwapPartition swap) = sequence + [ fromMaybe swap <$> getM (\a -> a swap) + [ uuidprefix getSourceUUID + , sourceprefix getSourceLabel + ] + , pure "none" + , pure "swap" + , pure (formatMountOpts mempty) + , pure "0" + , pure "0" + ] + prefix s getter m = fmap (s ++) <$> getter m + uuidprefix = prefix "UUID=" + sourceprefix = prefix "LABEL=" + +-- | Checks if </etc/fstab> is not configured. +-- This is the case if it doesn't exist, or +-- consists entirely of blank lines or comments. +-- +-- So, if you want to only replace the fstab once, and then never touch it +-- again, allowing local modifications: +-- +-- > check noFstab (fstabbed mnts []) +noFstab :: IO Bool +noFstab = ifM (doesFileExist "/etc/fstab") + ( null . filter iscfg . lines <$> readFile "/etc/fstab" + , return True + ) + where + iscfg l + | null l = False + | otherwise = not $ "#" `isPrefixOf` dropWhile isSpace l diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs @@ -0,0 +1,163 @@ +module Propellor.Property.Git where + +import Propellor.Base +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +import Data.List + +-- | Exports all git repos in a directory (that user nobody can read) +-- using git-daemon, run from inetd. +-- +-- Note that reverting this property does not remove or stop inetd. +daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike +daemonRunning exportdir = setup <!> unsetup + where + setup = containsLine conf (mkl "tcp4") + `requires` + containsLine conf (mkl "tcp6") + `requires` + dirExists exportdir + `requires` + Apt.serviceInstalledRunning "openbsd-inetd" + `onChange` + Service.reloaded "openbsd-inetd" + `describe` ("git-daemon exporting " ++ exportdir) + unsetup = lacksLine conf (mkl "tcp4") + `requires` + lacksLine conf (mkl "tcp6") + `onChange` + Service.reloaded "openbsd-inetd" + + conf = "/etc/inetd.conf" + + mkl tcpv = intercalate "\t" + [ "git" + , "stream" + , tcpv + , "nowait" + , "nobody" + , "/usr/bin/git" + , "git" + , "daemon" + , "--inetd" + , "--export-all" + , "--base-path=" ++ exportdir + , exportdir + ] + +installed :: Property DebianLike +installed = Apt.installed ["git"] + +type RepoUrl = String + +type Branch = String + +-- | Specified git repository is cloned to the specified directory. +-- +-- If the directory exists with some other content (either a non-git +-- repository, or a git repository cloned from some other location), +-- it will be recursively deleted first. +-- +-- A branch can be specified, to check out. +cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike +cloned owner url dir mbranch = check originurl go + `requires` installed + where + desc = "git cloned " ++ url ++ " to " ++ dir + gitconfig = dir </> ".git/config" + originurl = ifM (doesFileExist gitconfig) + ( do + v <- catchDefaultIO Nothing $ headMaybe . lines <$> + readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"] + return (v /= Just url) + , return True + ) + go :: Property DebianLike + go = property' desc $ \w -> do + liftIO $ do + whenM (doesDirectoryExist dir) $ + removeDirectoryRecursive dir + createDirectoryIfMissing True (takeDirectory dir) + ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds) + `assume` MadeChange + checkoutcmds = + -- The </dev/null fixes an intermittent + -- "fatal: read error: Bad file descriptor" + -- when run across ssh with propellor --spin + [ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null" + , Just $ "cd " ++ shellEscape dir + , ("git checkout " ++) <$> mbranch + -- In case this repo is exposted via the web, + -- although the hook to do this ongoing is not + -- installed here. + , Just "git update-server-info" + ] + +isGitDir :: FilePath -> IO Bool +isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir]) + +data GitShared = Shared Group | SharedAll | NotShared + +bareRepo :: FilePath -> User -> GitShared -> Property UnixLike +bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $ + dirExists repo : case gitshared of + NotShared -> + [ ownerGroup repo user (userGroup user) + , userScriptProperty user ["git init --bare --shared=false " ++ shellEscape repo] + `assume` MadeChange + ] + SharedAll -> + [ ownerGroup repo user (userGroup user) + , userScriptProperty user ["git init --bare --shared=all " ++ shellEscape repo] + `assume` MadeChange + ] + Shared group' -> + [ ownerGroup repo user group' + , userScriptProperty user ["git init --bare --shared=group " ++ shellEscape repo] + `assume` MadeChange + ] + where + isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo']) + +-- | Set a key value pair in a git repo's configuration. +repoConfigured :: FilePath -> (String, String) -> Property UnixLike +repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $ + userScriptProperty (User "root") + [ "cd " ++ repo + , "git config " ++ key ++ " " ++ value + ] + `assume` MadeChange + `describe` desc + where + alreadyconfigured = do + vs <- getRepoConfig repo key + return $ value `elem` vs + desc = "git repo at " ++ repo ++ " config setting " ++ key ++ " set to " ++ value + +-- | Gets the value that a key is set to in a git repo's configuration. +getRepoConfig :: FilePath -> String -> IO [String] +getRepoConfig repo key = catchDefaultIO [] $ + lines <$> readProcess "git" ["-C", repo, "config", key] + +-- | Whether a repo accepts non-fast-forward pushes. +repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike +repoAcceptsNonFFs repo = accepts <!> refuses + where + accepts = repoConfigured repo ("receive.denyNonFastForwards", "false") + `describe` desc "accepts" + refuses = repoConfigured repo ("receive.denyNonFastForwards", "true") + `describe` desc "rejects" + desc s = "git repo " ++ repo ++ " " ++ s ++ " non-fast-forward pushes" + +-- | Sets a bare repository's default branch, which will be checked out +-- when cloning it. +bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike +bareRepoDefaultBranch repo branch = + userScriptProperty (User "root") + [ "cd " ++ repo + , "git symbolic-ref HEAD refs/heads/" ++ branch + ] + `changesFileContent` (repo </> "HEAD") + `describe` ("git repo at " ++ repo ++ " has default branch " ++ branch) diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs @@ -0,0 +1,63 @@ +module Propellor.Property.Gpg where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import Utility.FileSystemEncoding + +import System.PosixCompat + +installed :: Property DebianLike +installed = Apt.installed ["gnupg"] + +-- A numeric id, or a description of the key, in a form understood by gpg. +newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String } + +data GpgKeyType = GpgPubKey | GpgPrivKey + +-- | Sets up a user with a gpg key from the privdata. +-- +-- Note that if a secret key is exported using gpg -a --export-secret-key, +-- the public key is also included. Or just a public key could be +-- exported, and this would set it up just as well. +-- +-- Recommend only using this for low-value dedicated role keys. +-- No attempt has been made to scrub the key out of memory once it's used. +keyImported :: GpgKeyId -> User -> Property (HasInfo + DebianLike) +keyImported key@(GpgKeyId keyid) user@(User u) = prop + `requires` installed + where + desc = u ++ " has gpg key " ++ show keyid + prop :: Property (HasInfo + DebianLike) + prop = withPrivData src (Context keyid) $ \getkey -> + property desc $ getkey $ \key' -> do + let keylines = privDataLines key' + ifM (liftIO $ hasGpgKey (parse keylines)) + ( return NoChange + , makeChange $ withHandle StdinHandle createProcessSuccess + (proc "su" ["-c", "gpg --import", u]) $ \h -> do + fileEncoding h + hPutStr h (unlines keylines) + hClose h + ) + src = PrivDataSource GpgKey "Either a gpg public key, exported with gpg --export -a, or a gpg private key, exported with gpg --export-secret-key -a" + + parse ("-----BEGIN PGP PUBLIC KEY BLOCK-----":_) = Just GpgPubKey + parse ("-----BEGIN PGP PRIVATE KEY BLOCK-----":_) = Just GpgPrivKey + parse _ = Nothing + + hasGpgKey Nothing = error $ "Failed to run gpg parser on armored key " ++ keyid + hasGpgKey (Just GpgPubKey) = hasPubKey key user + hasGpgKey (Just GpgPrivKey) = hasPrivKey key user + +hasPrivKey :: GpgKeyId -> User -> IO Bool +hasPrivKey (GpgKeyId keyid) (User u) = catchBoolIO $ + snd <$> processTranscript "su" ["-c", "gpg --list-secret-keys " ++ shellEscape keyid, u] Nothing + +hasPubKey :: GpgKeyId -> User -> IO Bool +hasPubKey (GpgKeyId keyid) (User u) = catchBoolIO $ + snd <$> processTranscript "su" ["-c", "gpg --list-public-keys " ++ shellEscape keyid, u] Nothing + +dotDir :: User -> IO FilePath +dotDir (User u) = do + home <- homeDirectory <$> getUserEntryForName u + return $ home </> ".gnupg" diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs @@ -0,0 +1,18 @@ +module Propellor.Property.Group where + +import Propellor.Base +import Propellor.Property.User (hasGroup) + +type GID = Int + +exists :: Group -> Maybe GID -> Property UnixLike +exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid)) + `describe` unwords ["group", group'] + where + groupFile = "/etc/group" + test = not . elem group' . words <$> readProcess "cut" ["-d:", "-f1", groupFile] + args Nothing = [group'] + args (Just gid) = ["--gid", show gid, group'] + +hasUser :: Group -> User -> Property DebianLike +hasUser = flip hasGroup diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs @@ -0,0 +1,87 @@ +module Propellor.Property.Grub where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +-- | Eg, \"hd0,0\" or \"xen/xvda1\" +type GrubDevice = String + +-- | Eg, \"\/dev/sda\" +type OSDevice = String + +type TimeoutSecs = Int + +-- | Types of machines that grub can boot. +data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen + +-- | Installs the grub package. This does not make grub be used as the +-- bootloader. +-- +-- This includes running update-grub. +installed :: BIOS -> Property DebianLike +installed bios = installed' bios `onChange` mkConfig + +-- Run update-grub, to generate the grub boot menu. It will be +-- automatically updated when kernel packages are installed. +mkConfig :: Property DebianLike +mkConfig = tightenTargets $ cmdProperty "update-grub" [] + `assume` MadeChange + +-- | Installs grub; does not run update-grub. +installed' :: BIOS -> Property Linux +installed' bios = (aptinstall `pickOS` unsupportedOS) + `describe` "grub package installed" + where + aptinstall :: Property DebianLike + aptinstall = Apt.installed [debpkg] + debpkg = case bios of + PC -> "grub-pc" + EFI64 -> "grub-efi-amd64" + EFI32 -> "grub-efi-ia32" + Coreboot -> "grub-coreboot" + Xen -> "grub-xen" + +-- | Installs grub onto a device, so the system can boot from that device. +-- +-- You may want to install grub to multiple devices; eg for a system +-- that uses software RAID. +-- +-- Note that this property does not check if grub is already installed +-- on the device; it always does the work to reinstall it. It's a good idea +-- to arrange for this property to only run once, by eg making it be run +-- onChange after OS.cleanInstallOnce. +boots :: OSDevice -> Property Linux +boots dev = tightenTargets $ cmdProperty "grub-install" [dev] + `assume` MadeChange + `describe` ("grub boots " ++ dev) + +-- | Use PV-grub chaining to boot +-- +-- Useful when the VPS's pv-grub is too old to boot a modern kernel image. +-- +-- <http://notes.pault.ag/linode-pv-grub-chainning/> +-- +-- The rootdev should be in the form "hd0", while the bootdev is in the form +-- "xen/xvda". +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike +chainPVGrub rootdev bootdev timeout = combineProperties desc $ props + & File.dirExists "/boot/grub" + & "/boot/grub/menu.lst" `File.hasContent` + [ "default 1" + , "timeout " ++ show timeout + , "" + , "title grub-xen shim" + , "root (" ++ rootdev ++ ")" + , "kernel /boot/xen-shim" + , "boot" + ] + & "/boot/load.cf" `File.hasContent` + [ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ] + & installed Xen + & flip flagFile "/boot/xen-shim" xenshim + where + desc = "chain PV-grub" + 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" diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -0,0 +1,29 @@ +module Propellor.Property.HostingProvider.CloudAtCost where + +import Propellor.Base +import qualified Propellor.Property.Hostname as Hostname +import qualified Propellor.Property.File as File +import qualified Propellor.Property.User as User + +-- Clean up a system as installed by cloudatcost.com +decruft :: Property DebianLike +decruft = propertyList "cloudatcost cleanup" $ props + & Hostname.sane + & grubbugfix + & nukecruft + where + grubbugfix :: Property DebianLike + grubbugfix = tightenTargets $ + "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" + `describe` "worked around grub/lvm boot bug #743126" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) + `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) + nukecruft :: Property Linux + nukecruft = tightenTargets $ + combineProperties "nuked cloudatcost cruft" $ props + & File.notPresent "/etc/rc.local" + & File.notPresent "/etc/init.d/S97-setup.sh" + & File.notPresent "/zang-debian.sh" + & File.notPresent "/bin/npasswd" + & User.nuked (User "user") User.YesReallyDeleteHome + diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -0,0 +1,26 @@ +module Propellor.Property.HostingProvider.DigitalOcean ( + distroKernel +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Reboot as Reboot + +-- | Digital Ocean does not provide any way to boot +-- the kernel provided by the distribution, except using kexec. +-- Without this, some old, and perhaps insecure kernel will be used. +-- +-- This property causes the distro kernel to be loaded on reboot, using kexec. +-- +-- When the power is cycled, the non-distro kernel still boots up. +-- So, this property also checks if the running kernel is present in /boot, +-- and if not, reboots immediately into a distro kernel. +distroKernel :: Property DebianLike +distroKernel = propertyList "digital ocean distro kernel hack" $ props + & Apt.installed ["grub-pc", "kexec-tools", "file"] + & "/etc/default/kexec" `File.containsLines` + [ "LOAD_KEXEC=true" + , "USE_GRUB_CONFIG=true" + ] `describe` "kexec configured" + & Reboot.toDistroKernel diff --git a/src/Propellor/Property/HostingProvider/Exoscale.hs b/src/Propellor/Property/HostingProvider/Exoscale.hs @@ -0,0 +1,37 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> +-- +-- Properties for use on <https://www.exoscale.ch/> + +module Propellor.Property.HostingProvider.Exoscale ( + distroKernel, +) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Reboot as Reboot + +-- | Flavor of kernel, eg "amd64" or "686" +type KernelFlavor = String + +-- | The current Exoshare Debian image doesn't install GRUB, so this property +-- makes sure GRUB is installed and correctly configured +-- +-- In case an old, insecure kernel is running, we check for an old kernel +-- version and reboot immediately if one is found. +-- +-- Note that we ignore anything after the first hyphen when considering +-- whether the running kernel's version is older than the Debian-supplied +-- kernel's version. +distroKernel :: KernelFlavor -> Property DebianLike +distroKernel kernelflavor = go `flagFile` theFlagFile + where + go = combineProperties "boots distro kernel" $ props + & Apt.installed ["grub2", "linux-image-" ++ kernelflavor] + & Grub.boots "/dev/vda" + & Grub.mkConfig + -- Since we're rebooting we have to manually create the flagfile + & File.hasContent theFlagFile [""] + & Reboot.toDistroKernel + theFlagFile = "/etc/propellor-distro-kernel" diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs @@ -0,0 +1,33 @@ +module Propellor.Property.HostingProvider.Linode where + +import Propellor.Base +import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.File as File +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 = "/etc/default/grub" `File.containsLines` + [ "GRUB_CMDLINE_LINUX=\"console=ttyS0,19200n8\"" + , "GRUB_DISABLE_LINUX_UUID=true" + , "GRUB_SERIAL_COMMAND=\"serial --speed=19200 --unit=0 --word=8 --parity=no --stop=1\"" + , "GRUB_TERMINAL=serial" + ] + `onChange` Grub.mkConfig + `requires` Grub.installed Grub.PC + +-- | 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.chainPVGrub "hd0" "xen/xvda" + +-- | Linode disables mlocate's cron job's execute permissions, +-- presumably to avoid disk IO. This ensures it's executable. +mlocateEnabled :: Property DebianLike +mlocateEnabled = tightenTargets $ + "/etc/cron.daily/mlocate" + `File.mode` combineModes (readModes ++ executeModes) + diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs @@ -0,0 +1,104 @@ +module Propellor.Property.Hostname where + +import Propellor.Base +import qualified Propellor.Property.File as File +import Propellor.Property.Chroot (inChroot) + +import Data.List +import Data.List.Utils + +-- | Ensures that the hostname is set using best practices, to whatever +-- name the `Host` has. +-- +-- Configures both </etc/hostname> and the current hostname. +-- (However, when used inside a chroot, avoids setting the current hostname +-- as that would impact the system outside the chroot.) +-- +-- Configures </etc/mailname> with the domain part of the hostname. +-- +-- </etc/hosts> is also configured, with an entry for 127.0.1.1, which is +-- standard at least on Debian to set the FDQN. +-- +-- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any +-- other hostnames there is not best practices and can lead to annoying +-- messages from eg, apache. +sane :: Property UnixLike +sane = sane' extractDomain + +sane' :: ExtractDomain -> Property UnixLike +sane' extractdomain = property' ("sane hostname") $ \w -> + ensureProperty w . setTo' extractdomain =<< asks hostName + +-- Like `sane`, but you can specify the hostname to use, instead +-- of the default hostname of the `Host`. +setTo :: HostName -> Property UnixLike +setTo = setTo' extractDomain + +setTo' :: ExtractDomain -> HostName -> Property UnixLike +setTo' extractdomain hn = combineProp