diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,36 @@ +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 Thu, 24 Mar 2016 14:53:31 -0400 + propellor (2.16.0) unstable; urgency=medium * Obnam: Only let one backup job run at a time when a host has multiple diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ CABAL?=cabal -DATE := $(shell dpkg-parsechangelog | grep Date | cut -d " " -f2-) +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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,8 @@ 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 diff --git a/config-freebsd.hs b/config-freebsd.hs new file mode 100644 --- /dev/null +++ b/config-freebsd.hs @@ -0,0 +1,67 @@ +-- 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" + & os (System (FreeBSD (FBSDProduction FBSD102)) "amd64") + & Pkg.update + & Pkg.upgrade + & Poudriere.poudriere poudriereZFS + & Poudriere.jail (Poudriere.Jail "formail" (fromString "10.2-RELEASE") (fromString "amd64")) + +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" + & os (System (Debian Unstable) "amd64") + & 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") + & os (System (Debian (Stable "jessie")) "amd64") + & Apt.stdSourcesList + & Docker.publish "80:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" + diff --git a/config-joey.hs b/config-joey.hs deleted file mode 100644 --- a/config-joey.hs +++ /dev/null @@ -1,629 +0,0 @@ --- 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.SiteSpecific.GitHome as GitHome -import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder -import qualified Propellor.Property.SiteSpecific.IABak as IABak -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 - , iabak - ] ++ monsters - -testvm :: Host -testvm = host "testvm.kitenet.net" - & os (System (Debian Unstable) "amd64") - & OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net") - `onChange` propertyList "fixing up after clean install" - [ OS.preserveRootSshAuthorized - , OS.preserveResolvConf - , Apt.update - , Grub.boots "/dev/sda" - `requires` Grub.installed Grub.PC - ] - & Hostname.sane - & Hostname.searchDomain - & Apt.installed ["linux-image-amd64"] - & Apt.installed ["ssh"] - & User.hasPassword (User "root") - -darkstar :: Host -darkstar = host "darkstar.kitenet.net" - & ipv6 "2001:4830:1600:187::2" - & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" - - & Apt.buildDep ["git-annex"] `period` Daily - - & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") - & JoeySites.dkimMilter - & JoeySites.alarmClock "*-*-* 7:30" (User "joey") - "/usr/bin/timeout 45m /home/joey/bin/goodmorning" - - & 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 - & os (System (Debian Unstable) "amd64") - & Hostname.setTo "demo" - & Apt.installed ["linux-image-amd64"] - & User "root" `User.hasInsecurePassword` "root" - -gnu :: Host -gnu = host "gnu.kitenet.net" - & Apt.buildDep ["git-annex"] `period` Daily - - & JoeySites.postfixClientRelay (Context "gnu.kitenet.net") - & JoeySites.dkimMilter - -clam :: Host -clam = standardSystem "clam.kitenet.net" Unstable "amd64" - [ "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 = standardSystem "mayfly.kitenet.net" (Stable "jessie") "amd64" - [ "Scratch VM. Contents can change at any time!" ] - & ipv4 "104.167.118.15" - - & 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 = standardSystem "oyster.kitenet.net" Unstable "amd64" - [ "Unreliable server. Anything here may be lost at any time!" ] - & ipv4 "104.167.117.109" - - & 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 80 - -orca :: Host -orca = standardSystem "orca.kitenet.net" Unstable "amd64" - [ "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 - (System (Debian Unstable) "amd64") Nothing fifteenpast "2h") - & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer - GitAnnexBuilder.standardAutoBuilder - (System (Debian Unstable) "i386") Nothing fifteenpast "2h") - & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer - GitAnnexBuilder.standardAutoBuilder - (System (Debian (Stable "jessie")) "i386") (Just "ancient") fifteenpast "2h") - & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer - (Cron.Times "1 1 * * *") "3h") - where - fifteenpast = Cron.Times "15 * * * *" - -honeybee :: Host -honeybee = standardSystem "honeybee.kitenet.net" 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 - (System (Debian 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 = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" - [ "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.chainPVGrub 5 - & Linode.mlocateEnabled - & Apt.unattendedUpgrades - & Systemd.installed - & Systemd.persistentJournal - & Journald.systemMaxUse "500MiB" - & Ssh.passwordAuthentication True - -- Since ssh password authentication is allowed: - & Fail2Ban.installed - & 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.kitenetHttps - & 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 = standardSystem "elephant.kitenet.net" Unstable "amd64" - [ "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 80 - -beaver :: Host -beaver = host "beaver.kitenet.net" - & 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" - & 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 "campaign.joeyh.name" - & alias "ikiwiki.info" - & alias "git.ikiwiki.info" - & alias "l10n.ikiwiki.info" - & alias "dist-bugs.kitenet.net" - & alias "family.kitenet.net" - - & Apt.installed ["linux-image-amd64"] - & Linode.chainPVGrub 5 - & Apt.unattendedUpgrades - & Branchable.server hosts - -iabak :: Host -iabak = host "iabak.archiveteam.org" - & ipv4 "124.6.40.227" - & Hostname.sane - & os (System (Debian Testing) "amd64") - & Systemd.persistentJournal - & Cron.runPropellor (Cron.Times "30 * * * *") - & Apt.stdSourcesList `onChange` Apt.upgrade - & Apt.installed ["git", "ssh"] - & Ssh.hostKeys (Context "iabak.archiveteam.org") - [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAMhuYTshLxavWCpfyJxg3j/GWyIRlL3VTharsfUTzMOqyMSWantZjflfJX21z2KzFDtPEA711GYztsgMVXMrsPQInaOKNISe/R9cfgnEktKTxeppWTfw0GTNcpCeeecddU0FCPVW3a6yDoT6+Rv0jPvkQoDGmhQ40MhauMrO0mJ9AAAAFQDpCbXG8o/3Sg7wrsp5abizJoQ0yQAAAIEAxxyHo/ZhDPP+EWtDS05s5dwiDMUsxIllk1NeleAOQIyLtFkaifOeskDJybIPWYPGX1trjcPoGuXJ5GBYrRaPiu6FBvYdYMFRLr4uNBsaSHHqlHhBPkP3RzCrdUyau4XyjdE4iA0EQlO+u11A+o3f7aTuJSveM0YRfbqvaatG89EAAACAWd0h0SkRLnGjBzkou0SQfYujFY9ilhWXPWV/oOs+bieDSpvfmnaEfLSinVFRrJPvQp/dtpxPLEm+StrK3w6dmwTZVUM5JEoB1mRjBkVs6gPC9PVVg9qLpzC2/x+r5cTfrffjyRrlPdkwLKpO6oiPxTIxAyCW8ixjafkxe2hAeJo=") - , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDP13oPRLRY0V9ZDWojb8TgHbUdE30Nq3b541TwPmlLMbYPAhldxGHkuXGlX8g9/FYP/1AgkPcxs2Uc61ZV+1Ss7q7t52f4R0bO4WHqxfdXHd9FlLzMLWxMU3aMr693pGlhnUp3/xH6O6/+bNEIo3VGGgv9XDr2cAxypS9J7X9ibHZcZ3BGvoCR+nnFJ00ERG2tREKZBPDWKk76lhCiM21fG/CSmcApXaA45FHDaM9/2Clj1sXvoS72f0hEKpl1m08sUx+F0GPzQESnKqNFl+xXdYPPbfhdrgCnDmx9tL5NnXsJU2beFiuxpICOeB1HV6DJsdlO18WqwXYhOg/2A1H3") - , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBHb0kXcrF5ThwS8wB0Hez404Zp9bz78ZxEGSqnwuF4d/N3+bymg7/HAj7l/SzRoEXKHsJ7P5320oMxBHeM16Y+k=") - ] - & Apt.installed ["etckeeper", "sudo"] - & Apt.installed ["vim", "screen", "tmux", "less", "emax-nox", "netcat"] - & User.hasSomePassword (User "root") - & propertyList "admin accounts" - (map User.accountFor admins ++ map Sudo.enabledFor admins) - & User.hasSomePassword (User "joey") - & GitHome.installedFor (User "joey") - & Ssh.authorizedKey (User "db48x") "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAAIAQDQ6urXcMDeyuFf4Ga7CuGezTShKnEMPHKJm7RQUtw3yXCPX5wnbvPS2+UFnHMzJvWOX5S5b/XpBpOusP0jLpxwOCEg4nA5b7uvWJ2VIChlMqopYMo+tDOYzK/Q74MZiNWi2hvf1tn3N9SnqOa7muBMKMENIX5KJdH8cJ/BaPqAP883gF8r2SwSZFvaB0xYCT/CIylC593n/+0+Lm07NUJIO8jil3n2SwXdVg6ib65FxZoO86M46wTghnB29GXqrzraOg+5DY1zzCWpIUtFwGr4DP0HqLVtmAkC7NI14l1M0oHE0UEbhoLx/a+mOIMD2DuzW3Rs3ZmHtGLj4PL/eBU8D33AqSeM0uR/0pEcoq6A3a8ixibj9MBYD2lMh+Doa2audxS1OLM//FeNccbm1zlvvde82PZtiO11P98uN+ja4A+CfgQU5s0z0wikc4gXNhWpgvz8DrOEJrjstwOoqkLg2PpIdHRw7dhpp3K1Pc+CGAptDwbKkxs4rzUgMbO9DKI7fPcXXgKHLLShMpmSA2vsQUMfuCp2cVrQJ+Vkbwo29N0Js5yU7L4NL4H854Nbk5uwWJCs/mjXtvTimN2va23HEecTpk44HDUjJ9NyevAfPcO9q1ZtgXFTQSMcdv1m10Fvmnaiy8biHnopL6MBo1VRITh5UFiJYfK4kpTTg2vSspii/FYkkYOAnnZtXZqMehP7OZjJ6HWJpsCVR2hxP3sKOoQu+kcADWa/4obdp+z7gY8iMMjd6kwuIWsNV8KsX+eVJ4UFpAi/L00ZjI2B9QLVCsOg6D1fT0698wEchwUROy5vZZJq0078BdAGnwC0WGLt+7OUgn3O2gUAkb9ffD0odbZSqq96NCelM6RaHA+AaIE4tjGL3lFkyOtb+IGPNACQ73/lmaRQd6Cgasq9cEo0g22Ew5NQi0CBuu1aLDk7ezu3SbU09eB9lcZ+8lFnl5K2eQFeVJStFJbJNfOvgKyOb7ePsrUFF5GJ2J/o1F60fRnG64HizZHxyFWkEOh+k3i8qO+whPa5MTQeYLYb6ysaTPrUwNRcSNNCcPEN8uYOh1dOFAtIYDcYA56BZ321yz0b5umj+pLsrFU+4wMjWxZi0inJzDS4dVegBVcRm0NP5u8VRosJQE9xdbt5K1I0khzhrEW1kowoTbhsZCaDHhL9LZo73Z1WIHvulvlF3RLZip5hhtQu3ZVkbdV5uts8AWaEWVnIu9z0GtQeeOuseZpT0u1/1xjVAOKIzuY3sB7FKOaipe8TDvmdiQf/ICySqqYaYhN6GOhiYccSleoX6yzhYuCvzTgAyWHIfW0t25ff1CM7Vn+Vo9cVplIer1pbwhZZy4QkROWTOE+3yuRlQ+o6op4hTGdAZhjKh9zkDW7rzqQECFrZrX/9mJhxYKjhpkk0X3dSipPt9SUHagc4igya+NgCygQkWBOQfr4uia0LcwDxy4Kchw7ZuypHuGVZkGhNHXS+9JdAHopnSqYwDMG/z1ys1vQihgER0b9g3TchvGF+nmHe2kbM1iuIYMNNlaZD1yGZ5qR7wr/8dw8r0NBEwzsUfak3BUPX7H6X0tGS96llwUxmvQD85WNNoef0uryuAtDEwWlfN1RmWysZDc57Rn4gZi0M5jXmQD23ZiYXYBcG849OeqNzlxONEFsForXO/29Ud4x/Hqa9tf+kJbqMRsaLFO+PXhHzgl6ZHLAljQDxrJ6keNnkqaYfqQ8wyRi1mKv4Ab57kde7mUsZhe7w93GaE9Lxfvu7d3pB+lXfI9NJCSITHreUP4JfmFW+p/eVg+r/1wbElNylGna4I4+qYObOUncGwFKYdFPdtU1XLDKXmywTEgbEh7iI9zX0xD3bPHQLMg+TTtXiU9dQm1x/0zRf9trwDsRDJCbG4/P4iQYkcVvYx2CCfi0JSHv8tWsLi3GJKJLXUxZyzfvY2lThPeYnnY/HFrPJCyJUN55QuRmfzbu8rHgWlcyOlVpKtz+7kn823kEQykiIYKIKrb0G6VBzuMtAk9XzJPv+Wu7suOGXHlVfCqPLk6RjHDm4kTYciW9VgxDts5Y+zwcAbrUeA4UuN/6KisWpivMrfDSIHUCeH/lHBtNkqKohdrUKJMEOx5X6r2dJbmoTFBDi5XtYu/5cBtiDMmupNB0S+pZ2JD5/RKtj6kgzTeE1q/OG4q/eq1O1rjf0vIS31luy27K/YHFIGE0D/CmuXE74Uyaxm27RnrKUxEBl84V70GaIF4F5On8pSThxxizigXTRTKiczc+A5Zi29mid+1EFeUAJOa/DuHJfpVNY4pYEmhPl/Bk66L8kzlbJz6Hg/LIiJIRcy3UKrbSxPFIDpXn33drBHgklMDlrIVDZDXF6cn0Ml71SabB4A3TM6TK+oWZoyvftPIhcWhVwAWQj7nFNAiMEl1z/29ovHrRooqQFozf7GDW8Mjiu7ChZP9zx2H8JB/AAEFuWMwGV4AHICYdS9lOl/v+cDhgsnXdeuKEuxHhYlRxuRxJk/f17Sm/5H85UIzlu85wi3q/DW2FTZnlw4iJLnL6FArUIMzuBOZyoEhh0SPR41Xc4kkucDhnENybTZSR/yDzb0P1B7qjZ4GqcSEFja/hm/LH1oKJzZg8MEqeUoKYCUdVv9ek4IUGUONtVs53V5SOwFWR/nVuDk2BENr7NadYYVtu6MjBwgjso7NuhoNxVwIEP3BW67OQ8bxfNBtJJQNJejAhgZiqJItI9ucAfjQ== db48x@anglachel" - & Apt.installed ["sudo"] - & Ssh.noPasswords - & IABak.gitServer monsters - & IABak.registrationServer monsters - & IABak.graphiteServer - & IABak.publicFace - where - admins = map User ["joey", "db48x"] - - --' __|II| ,. - ---- __|II|II|__ ( \_,/\ ---'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'- --------------------------- | [Containers] / -------------------------- --------------------------- : / --------------------------- ---------------------------- \____, o ,' ---------------------------- ----------------------------- '--,___________,' ----------------------------- - --- Simple web server, publishing the outside host's /var/www -webserver :: Systemd.Container -webserver = standardStableContainer "webserver" - & Systemd.bind "/var/www" - & Apache.installed - --- My own openid provider. Uses php, so containerized for security --- and administrative sanity. -openidProvider :: Systemd.Container -openidProvider = standardStableContainer "openid-provider" - & 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 = standardStableContainer "ancient-kitenet" - & 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 = standardStableContainer "oldusenet-shellbox" - & alias "shell.olduse.net" - & JoeySites.oldUseNetShellBox - -kiteShellBox :: Systemd.Container -kiteShellBox = standardStableContainer "kiteshellbox" - & JoeySites.kiteShellBox - -type Motd = [String] - --- This is my standard system setup. -standardSystem :: HostName -> DebianSuite -> Architecture -> Motd -> Host -standardSystem hn suite arch motd = standardSystemUnhardened hn suite arch motd - & Ssh.noPasswords - -standardSystemUnhardened :: HostName -> DebianSuite -> Architecture -> Motd -> Host -standardSystemUnhardened hn suite arch motd = host hn - & os (System (Debian 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 - --- This is my standard container setup, Featuring automatic upgrades. -standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container -standardContainer name suite arch = - Systemd.container name system (Chroot.debootstrapped mempty) - & Apt.stdSourcesList `onChange` Apt.upgrade - & Apt.unattendedUpgrades - & Apt.cacheCleaned - where - system = System (Debian suite) arch - -standardStableContainer :: Systemd.MachineName -> Systemd.Container -standardStableContainer name = standardContainer name (Stable "jessie") "amd64" - -myDnsSecondary :: Property HasInfo -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 -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 -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" - & Ssh.hostPubKey SshEd25519 "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB7yTEBGfQYdwG/oeL+U9XPMIh/dW7XNs9T+M79YIOrd" - , host "github.com" - & Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" - , host "gitlab.com" - & Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY=" - , host "ns6.gandi.net" - & ipv4 "217.70.177.40" - , host "turtle.kitenet.net" - & ipv4 "67.223.19.96" - & ipv6 "2001:4978:f:2d9::2" - , host "mouse.kitenet.net" - & ipv6 "2001:4830:1600:492::2" - , host "animx" - & 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/contrib/post-merge-hook b/contrib/post-merge-hook new file mode 100644 --- /dev/null +++ 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 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,36 @@ +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 Thu, 24 Mar 2016 14:53:31 -0400 + propellor (2.16.0) unstable; urgency=medium * Obnam: Only let one backup job run at a time when a host has multiple diff --git a/doc/README.mdwn b/doc/README.mdwn --- a/doc/README.mdwn +++ b/doc/README.mdwn @@ -2,6 +2,8 @@ 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 diff --git a/joeyconfig.hs b/joeyconfig.hs new file mode 100644 --- /dev/null +++ b/joeyconfig.hs @@ -0,0 +1,627 @@ +-- 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.SiteSpecific.GitHome as GitHome +import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder +import qualified Propellor.Property.SiteSpecific.IABak as IABak +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 + , iabak + ] ++ monsters + +testvm :: Host +testvm = host "testvm.kitenet.net" + & os (System (Debian Unstable) "amd64") + & OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net") + `onChange` propertyList "fixing up after clean install" + [ OS.preserveRootSshAuthorized + , OS.preserveResolvConf + , Apt.update + , Grub.boots "/dev/sda" + `requires` Grub.installed Grub.PC + ] + & Hostname.sane + & Hostname.searchDomain + & Apt.installed ["linux-image-amd64"] + & Apt.installed ["ssh"] + & User.hasPassword (User "root") + +darkstar :: Host +darkstar = host "darkstar.kitenet.net" + & ipv6 "2001:4830:1600:187::2" + & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" + + & Apt.buildDep ["git-annex"] `period` Daily + + & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") + & JoeySites.dkimMilter + & JoeySites.alarmClock "*-*-* 7:30" (User "joey") + "/usr/bin/timeout 45m /home/joey/bin/goodmorning" + + ! 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 + & os (System (Debian Unstable) "amd64") + & Hostname.setTo "demo" + & Apt.installed ["linux-image-amd64"] + & User "root" `User.hasInsecurePassword` "root" + +gnu :: Host +gnu = host "gnu.kitenet.net" + & Apt.buildDep ["git-annex"] `period` Daily + + & JoeySites.postfixClientRelay (Context "gnu.kitenet.net") + & JoeySites.dkimMilter + +clam :: Host +clam = standardSystem "clam.kitenet.net" Unstable "amd64" + [ "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 = standardSystem "mayfly.kitenet.net" (Stable "jessie") "amd64" + [ "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 = standardSystem "oyster.kitenet.net" Unstable "amd64" + [ "Unreliable server. Anything here may be lost at any time!" ] + & ipv4 "104.167.117.109" + + & 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 = standardSystem "orca.kitenet.net" Unstable "amd64" + [ "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 + (System (Debian Unstable) "amd64") Nothing (Cron.Times "15 * * * *") "2h") + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.standardAutoBuilder + (System (Debian Unstable) "i386") Nothing (Cron.Times "30 * * * *") "2h") + & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer + GitAnnexBuilder.stackAutoBuilder + (System (Debian (Stable "jessie")) "i386") (Just "ancient") (Cron.Times "45 * * * *") "2h") + & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer + (Cron.Times "1 1 * * *") "3h") + +honeybee :: Host +honeybee = standardSystem "honeybee.kitenet.net" 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 + (System (Debian 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 = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" + [ "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.chainPVGrub 5 + & Linode.mlocateEnabled + & Apt.unattendedUpgrades + & Systemd.installed + & Systemd.persistentJournal + & Journald.systemMaxUse "500MiB" + & Ssh.passwordAuthentication True + -- Since ssh password authentication is allowed: + & Fail2Ban.installed + & 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.kitenetHttps + & 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 = standardSystem "elephant.kitenet.net" Unstable "amd64" + [ "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" + & 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" + & 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 "campaign.joeyh.name" + & alias "ikiwiki.info" + & alias "git.ikiwiki.info" + & alias "l10n.ikiwiki.info" + & alias "dist-bugs.kitenet.net" + & alias "family.kitenet.net" + + & Apt.installed ["linux-image-amd64"] + & Linode.chainPVGrub 5 + & Apt.unattendedUpgrades + & Branchable.server hosts + +iabak :: Host +iabak = host "iabak.archiveteam.org" + & ipv4 "124.6.40.227" + & Hostname.sane + & os (System (Debian Testing) "amd64") + & Systemd.persistentJournal + & Cron.runPropellor (Cron.Times "30 * * * *") + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.installed ["git", "ssh"] + & Ssh.hostKeys (Context "iabak.archiveteam.org") + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAMhuYTshLxavWCpfyJxg3j/GWyIRlL3VTharsfUTzMOqyMSWantZjflfJX21z2KzFDtPEA711GYztsgMVXMrsPQInaOKNISe/R9cfgnEktKTxeppWTfw0GTNcpCeeecddU0FCPVW3a6yDoT6+Rv0jPvkQoDGmhQ40MhauMrO0mJ9AAAAFQDpCbXG8o/3Sg7wrsp5abizJoQ0yQAAAIEAxxyHo/ZhDPP+EWtDS05s5dwiDMUsxIllk1NeleAOQIyLtFkaifOeskDJybIPWYPGX1trjcPoGuXJ5GBYrRaPiu6FBvYdYMFRLr4uNBsaSHHqlHhBPkP3RzCrdUyau4XyjdE4iA0EQlO+u11A+o3f7aTuJSveM0YRfbqvaatG89EAAACAWd0h0SkRLnGjBzkou0SQfYujFY9ilhWXPWV/oOs+bieDSpvfmnaEfLSinVFRrJPvQp/dtpxPLEm+StrK3w6dmwTZVUM5JEoB1mRjBkVs6gPC9PVVg9qLpzC2/x+r5cTfrffjyRrlPdkwLKpO6oiPxTIxAyCW8ixjafkxe2hAeJo=") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDP13oPRLRY0V9ZDWojb8TgHbUdE30Nq3b541TwPmlLMbYPAhldxGHkuXGlX8g9/FYP/1AgkPcxs2Uc61ZV+1Ss7q7t52f4R0bO4WHqxfdXHd9FlLzMLWxMU3aMr693pGlhnUp3/xH6O6/+bNEIo3VGGgv9XDr2cAxypS9J7X9ibHZcZ3BGvoCR+nnFJ00ERG2tREKZBPDWKk76lhCiM21fG/CSmcApXaA45FHDaM9/2Clj1sXvoS72f0hEKpl1m08sUx+F0GPzQESnKqNFl+xXdYPPbfhdrgCnDmx9tL5NnXsJU2beFiuxpICOeB1HV6DJsdlO18WqwXYhOg/2A1H3") + , (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBHb0kXcrF5ThwS8wB0Hez404Zp9bz78ZxEGSqnwuF4d/N3+bymg7/HAj7l/SzRoEXKHsJ7P5320oMxBHeM16Y+k=") + ] + & Apt.installed ["etckeeper", "sudo"] + & Apt.installed ["vim", "screen", "tmux", "less", "emax-nox", "netcat"] + & User.hasSomePassword (User "root") + & propertyList "admin accounts" + (map User.accountFor admins ++ map Sudo.enabledFor admins) + & User.hasSomePassword (User "joey") + & GitHome.installedFor (User "joey") + & Ssh.authorizedKey (User "db48x") "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAAIAQDQ6urXcMDeyuFf4Ga7CuGezTShKnEMPHKJm7RQUtw3yXCPX5wnbvPS2+UFnHMzJvWOX5S5b/XpBpOusP0jLpxwOCEg4nA5b7uvWJ2VIChlMqopYMo+tDOYzK/Q74MZiNWi2hvf1tn3N9SnqOa7muBMKMENIX5KJdH8cJ/BaPqAP883gF8r2SwSZFvaB0xYCT/CIylC593n/+0+Lm07NUJIO8jil3n2SwXdVg6ib65FxZoO86M46wTghnB29GXqrzraOg+5DY1zzCWpIUtFwGr4DP0HqLVtmAkC7NI14l1M0oHE0UEbhoLx/a+mOIMD2DuzW3Rs3ZmHtGLj4PL/eBU8D33AqSeM0uR/0pEcoq6A3a8ixibj9MBYD2lMh+Doa2audxS1OLM//FeNccbm1zlvvde82PZtiO11P98uN+ja4A+CfgQU5s0z0wikc4gXNhWpgvz8DrOEJrjstwOoqkLg2PpIdHRw7dhpp3K1Pc+CGAptDwbKkxs4rzUgMbO9DKI7fPcXXgKHLLShMpmSA2vsQUMfuCp2cVrQJ+Vkbwo29N0Js5yU7L4NL4H854Nbk5uwWJCs/mjXtvTimN2va23HEecTpk44HDUjJ9NyevAfPcO9q1ZtgXFTQSMcdv1m10Fvmnaiy8biHnopL6MBo1VRITh5UFiJYfK4kpTTg2vSspii/FYkkYOAnnZtXZqMehP7OZjJ6HWJpsCVR2hxP3sKOoQu+kcADWa/4obdp+z7gY8iMMjd6kwuIWsNV8KsX+eVJ4UFpAi/L00ZjI2B9QLVCsOg6D1fT0698wEchwUROy5vZZJq0078BdAGnwC0WGLt+7OUgn3O2gUAkb9ffD0odbZSqq96NCelM6RaHA+AaIE4tjGL3lFkyOtb+IGPNACQ73/lmaRQd6Cgasq9cEo0g22Ew5NQi0CBuu1aLDk7ezu3SbU09eB9lcZ+8lFnl5K2eQFeVJStFJbJNfOvgKyOb7ePsrUFF5GJ2J/o1F60fRnG64HizZHxyFWkEOh+k3i8qO+whPa5MTQeYLYb6ysaTPrUwNRcSNNCcPEN8uYOh1dOFAtIYDcYA56BZ321yz0b5umj+pLsrFU+4wMjWxZi0inJzDS4dVegBVcRm0NP5u8VRosJQE9xdbt5K1I0khzhrEW1kowoTbhsZCaDHhL9LZo73Z1WIHvulvlF3RLZip5hhtQu3ZVkbdV5uts8AWaEWVnIu9z0GtQeeOuseZpT0u1/1xjVAOKIzuY3sB7FKOaipe8TDvmdiQf/ICySqqYaYhN6GOhiYccSleoX6yzhYuCvzTgAyWHIfW0t25ff1CM7Vn+Vo9cVplIer1pbwhZZy4QkROWTOE+3yuRlQ+o6op4hTGdAZhjKh9zkDW7rzqQECFrZrX/9mJhxYKjhpkk0X3dSipPt9SUHagc4igya+NgCygQkWBOQfr4uia0LcwDxy4Kchw7ZuypHuGVZkGhNHXS+9JdAHopnSqYwDMG/z1ys1vQihgER0b9g3TchvGF+nmHe2kbM1iuIYMNNlaZD1yGZ5qR7wr/8dw8r0NBEwzsUfak3BUPX7H6X0tGS96llwUxmvQD85WNNoef0uryuAtDEwWlfN1RmWysZDc57Rn4gZi0M5jXmQD23ZiYXYBcG849OeqNzlxONEFsForXO/29Ud4x/Hqa9tf+kJbqMRsaLFO+PXhHzgl6ZHLAljQDxrJ6keNnkqaYfqQ8wyRi1mKv4Ab57kde7mUsZhe7w93GaE9Lxfvu7d3pB+lXfI9NJCSITHreUP4JfmFW+p/eVg+r/1wbElNylGna4I4+qYObOUncGwFKYdFPdtU1XLDKXmywTEgbEh7iI9zX0xD3bPHQLMg+TTtXiU9dQm1x/0zRf9trwDsRDJCbG4/P4iQYkcVvYx2CCfi0JSHv8tWsLi3GJKJLXUxZyzfvY2lThPeYnnY/HFrPJCyJUN55QuRmfzbu8rHgWlcyOlVpKtz+7kn823kEQykiIYKIKrb0G6VBzuMtAk9XzJPv+Wu7suOGXHlVfCqPLk6RjHDm4kTYciW9VgxDts5Y+zwcAbrUeA4UuN/6KisWpivMrfDSIHUCeH/lHBtNkqKohdrUKJMEOx5X6r2dJbmoTFBDi5XtYu/5cBtiDMmupNB0S+pZ2JD5/RKtj6kgzTeE1q/OG4q/eq1O1rjf0vIS31luy27K/YHFIGE0D/CmuXE74Uyaxm27RnrKUxEBl84V70GaIF4F5On8pSThxxizigXTRTKiczc+A5Zi29mid+1EFeUAJOa/DuHJfpVNY4pYEmhPl/Bk66L8kzlbJz6Hg/LIiJIRcy3UKrbSxPFIDpXn33drBHgklMDlrIVDZDXF6cn0Ml71SabB4A3TM6TK+oWZoyvftPIhcWhVwAWQj7nFNAiMEl1z/29ovHrRooqQFozf7GDW8Mjiu7ChZP9zx2H8JB/AAEFuWMwGV4AHICYdS9lOl/v+cDhgsnXdeuKEuxHhYlRxuRxJk/f17Sm/5H85UIzlu85wi3q/DW2FTZnlw4iJLnL6FArUIMzuBOZyoEhh0SPR41Xc4kkucDhnENybTZSR/yDzb0P1B7qjZ4GqcSEFja/hm/LH1oKJzZg8MEqeUoKYCUdVv9ek4IUGUONtVs53V5SOwFWR/nVuDk2BENr7NadYYVtu6MjBwgjso7NuhoNxVwIEP3BW67OQ8bxfNBtJJQNJejAhgZiqJItI9ucAfjQ== db48x@anglachel" + & Apt.installed ["sudo"] + & Ssh.noPasswords + & IABak.gitServer monsters + & IABak.registrationServer monsters + & IABak.graphiteServer + & IABak.publicFace + where + admins = map User ["joey", "db48x"] + + --' __|II| ,. + ---- __|II|II|__ ( \_,/\ +--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'- +-------------------------- | [Containers] / -------------------------- +-------------------------- : / --------------------------- +--------------------------- \____, o ,' ---------------------------- +---------------------------- '--,___________,' ----------------------------- + +-- Simple web server, publishing the outside host's /var/www +webserver :: Systemd.Container +webserver = standardStableContainer "webserver" + & Systemd.bind "/var/www" + & Apache.installed + +-- My own openid provider. Uses php, so containerized for security +-- and administrative sanity. +openidProvider :: Systemd.Container +openidProvider = standardStableContainer "openid-provider" + & 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 = standardStableContainer "ancient-kitenet" + & 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 = standardStableContainer "oldusenet-shellbox" + & alias "shell.olduse.net" + & JoeySites.oldUseNetShellBox + +kiteShellBox :: Systemd.Container +kiteShellBox = standardStableContainer "kiteshellbox" + & JoeySites.kiteShellBox + +type Motd = [String] + +-- This is my standard system setup. +standardSystem :: HostName -> DebianSuite -> Architecture -> Motd -> Host +standardSystem hn suite arch motd = standardSystemUnhardened hn suite arch motd + & Ssh.noPasswords + +standardSystemUnhardened :: HostName -> DebianSuite -> Architecture -> Motd -> Host +standardSystemUnhardened hn suite arch motd = host hn + & os (System (Debian 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 + +-- This is my standard container setup, Featuring automatic upgrades. +standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container +standardContainer name suite arch = + Systemd.container name system (Chroot.debootstrapped mempty) + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.unattendedUpgrades + & Apt.cacheCleaned + where + system = System (Debian suite) arch + +standardStableContainer :: Systemd.MachineName -> Systemd.Container +standardStableContainer name = standardContainer name (Stable "jessie") "amd64" + +myDnsSecondary :: Property HasInfo +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 +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 +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" + & Ssh.hostPubKey SshEd25519 "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB7yTEBGfQYdwG/oeL+U9XPMIh/dW7XNs9T+M79YIOrd" + , host "github.com" + & Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" + , host "gitlab.com" + & Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY=" + , host "ns6.gandi.net" + & ipv4 "217.70.177.40" + , host "turtle.kitenet.net" + & ipv4 "67.223.19.96" + & ipv6 "2001:4978:f:2d9::2" + , host "mouse.kitenet.net" + & ipv6 "2001:4830:1600:492::2" + , host "animx" + & 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 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.16.0 +Version: 2.17.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess @@ -16,8 +16,10 @@ CHANGELOG Makefile config-simple.hs - config-joey.hs + config-freebsd.hs + joeyconfig.hs config.hs + contrib/post-merge-hook debian/changelog debian/README.Debian debian/compat @@ -36,10 +38,12 @@ Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs Hs-Source-Dirs: src - Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, - IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers (>= 0.5), network, async, time, mtl, transformers, - exceptions (>= 0.6), stm, text, unix + Build-Depends: + -- propellor needs to support the ghc shipped 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 Executable propellor-config Main-Is: config.hs @@ -83,6 +87,9 @@ Propellor.Property.Fail2Ban Propellor.Property.File Propellor.Property.Firewall + Propellor.Property.FreeBSD + Propellor.Property.FreeBSD.Pkg + Propellor.Property.FreeBSD.Poudriere Propellor.Property.Git Propellor.Property.Gpg Propellor.Property.Group @@ -117,6 +124,9 @@ 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.Linode @@ -146,6 +156,7 @@ Propellor.Types.Result Propellor.Types.ResultCheck Propellor.Types.CmdLine + Propellor.Types.ZFS Other-Modules: Propellor.Bootstrap Propellor.Git @@ -175,6 +186,7 @@ Utility.PosixFiles Utility.Process Utility.Process.Shim + Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled Utility.Table diff --git a/src/Propellor.hs b/src/Propellor.hs --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -72,3 +72,4 @@ import Propellor.PropAccum import Data.Monoid as X +import Data.String as X (fromString) diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -15,16 +15,16 @@ -- 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 :: ShellCommand -bootstrapPropellorCommand = checkDepsCommand ++ - "&& if ! test -x ./propellor; then " - ++ buildCommand ++ +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 2>/dev/null; then " ++ go ++ "; fi" +checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi" where go = intercalate " && " [ "cabal clean" @@ -34,14 +34,14 @@ buildCommand :: ShellCommand buildCommand = intercalate " && " [ "cabal configure" - , "cabal build" + , "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 :: ShellCommand -checkDepsCommand = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand ++ "; fi" +checkDepsCommand :: Maybe System -> ShellCommand +checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi" -- Install build dependencies of propellor. -- @@ -53,17 +53,25 @@ -- So, as a second step, cabal is used to install all dependencies. -- -- Note: May succeed and leave some deps not installed. -depsCommand :: ShellCommand -depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true" +depsCommand :: Maybe System -> ShellCommand +depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true" where - osinstall = "apt-get update" : map aptinstall debdeps + 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 - cabalinstall = + useapt = "apt-get update" : map aptinstall debdeps + + cabalinstall = [ "cabal update" , "cabal install --only-dependencies" ] aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get --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 = @@ -84,9 +92,41 @@ , "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 :: ShellCommand -installGitCommand = "if ! git --version >/dev/null; then apt-get update && DEBIAN_FRONTEND=noninteractive apt-get --no-install-recommends --no-upgrade -y install git; fi" +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 --no-install-recommends --no-upgrade -y install git" + ] buildPropellor :: IO () buildPropellor = unlessM (actionMessage "Propellor build" build) $ @@ -101,7 +141,7 @@ build = catchBoolIO $ do make "dist/setup-config" ["propellor.cabal"] $ cabal ["configure"] - unlessM (cabal ["build"]) $ do + unlessM (cabal ["build", "propellor-config"]) $ do void $ cabal ["configure"] unlessM (cabal ["build"]) $ error "cabal build failed" diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -21,7 +21,7 @@ import qualified Propellor.Shim as Shim usage :: Handle -> IO () -usage h = hPutStrLn h $ unlines +usage h = hPutStrLn h $ unlines [ "Usage:" , " propellor" , " propellor hostname" @@ -47,10 +47,10 @@ processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs where - go ("--check":_) = return Check + go ("--check":_) = return Check go ("--spin":ps) = case reverse ps of - (r:"--via":hs) -> Spin - <$> mapM hostname (reverse hs) + (r:"--via":hs) -> Spin + <$> mapM hostname (reverse hs) <*> pure (Just r) _ -> Spin <$> mapM hostname ps <*> pure Nothing go ("--add-key":k:[]) = return $ AddKey k @@ -62,7 +62,7 @@ go ("--edit":f:c:[]) = withprivfield f c Edit go ("--list-fields":[]) = return ListFields go ("--merge":[]) = return Merge - go ("--help":_) = do + go ("--help":_) = do usage stdout exitFailure go ("--boot":_:[]) = return $ Update Nothing -- for back-compat @@ -88,6 +88,8 @@ 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 @@ -95,10 +97,9 @@ checkDebugMode cmdline <- processCmdLine debug ["command line: ", show cmdline] - go True cmdline + go CanRebuild cmdline where - go _ (Serialized cmdline) = go True cmdline - go _ (Continue cmdline) = go False cmdline + go cr (Serialized cmdline) = go cr cmdline go _ Check = return () go _ (Set field context) = setPrivData field context go _ (Unset field context) = unsetPrivData field context @@ -112,26 +113,29 @@ go _ (DockerChain hn cid) = Docker.chain hostlist hn cid go _ (DockerInit hn) = Docker.init hn go _ (GitPush fin fout) = gitPushHelper fin fout - go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h)) - go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing)) + go cr (Relay h) = forceConsole >> + updateFirst 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 True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline - go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin hs mrelay) = do + go cr cmdline@(Spin hs mrelay) = buildFirst cr cmdline $ do unless (isJust mrelay) commitSpin forM_ hs $ \hn -> withhost hn $ spin mrelay hn - go False cmdline@(SimpleRun hn) = do - forceConsole - buildFirst cmdline $ go False (Run hn) - go False (Run hn) = ifM ((==) 0 <$> getRealUserID) - ( onlyprocess $ withhost hn mainProperties - , go True (Spin [hn] Nothing) + go cr cmdline@(Run hn) = ifM ((==) 0 <$> getRealUserID) + ( updateFirst cr cmdline $ runhost hn + , fetchFirst $ go cr (Spin [hn] Nothing) ) + go cr cmdline@(SimpleRun hn) = forceConsole >> + fetchFirst (buildFirst 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 @@ -142,39 +146,53 @@ , "Known hosts: " ++ unwords (map hostName hosts) ] -buildFirst :: CmdLine -> IO () -> IO () -buildFirst cmdline next = do +-- Builds propellor (when allowed) and if it looks like a new binary, +-- re-execs it to continue. +-- Otherwise, runs the IO action to continue. +buildFirst :: CanRebuild -> CmdLine -> IO () -> IO () +buildFirst CanRebuild cmdline next = do oldtime <- getmtime buildPropellor newtime <- getmtime if newtime == oldtime then next - else void $ boolSystem "./propellor" - [ Param "--continue" - , Param (show cmdline) - ] + 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 :: CmdLine -> IO () -> IO () -updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next) +updateFirst :: CanRebuild -> CmdLine -> IO () -> IO () +updateFirst canrebuild cmdline next = ifM hasOrigin + ( updateFirst' canrebuild cmdline next + , next + ) -updateFirst' :: CmdLine -> IO () -> IO () -updateFirst' cmdline next = ifM fetchOrigin +-- 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' :: CanRebuild -> CmdLine -> IO () -> IO () +updateFirst' CanRebuild cmdline next = ifM fetchOrigin ( do buildPropellor - void $ boolSystem "./propellor" - [ Param "--continue" - , Param (show cmdline) - ] + 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. @@ -186,5 +204,5 @@ go (AddrInfo { addrCanonName = Just v } : _) = pure v go _ | "." `isInfixOf` s = pure s -- assume it's a fqdn - | otherwise = + | otherwise = error $ "cannot find host " ++ s ++ " in the DNS" diff --git a/src/Propellor/Git/Config.hs b/src/Propellor/Git/Config.hs --- a/src/Propellor/Git/Config.hs +++ b/src/Propellor/Git/Config.hs @@ -14,7 +14,7 @@ getGitConfigValue key = do value <- catchMaybeIO $ takeWhile (/= '\n') - <$> readProcess "git" ["config", key] + <$> readProcess"git" ["config", key] return $ case value of Just v | not (null v) -> Just v _ -> Nothing diff --git a/src/Propellor/Git/VerifiedBranch.hs b/src/Propellor/Git/VerifiedBranch.hs --- a/src/Propellor/Git/VerifiedBranch.hs +++ b/src/Propellor/Git/VerifiedBranch.hs @@ -2,7 +2,6 @@ import Propellor.Base import Propellor.Git -import Propellor.Gpg import Propellor.PrivData.Paths import Utility.FileMode @@ -14,6 +13,7 @@ verifyOriginBranch :: String -> IO Bool verifyOriginBranch originbranch = do let gpgconf = privDataDir "gpg.conf" + keyring <- privDataKeyring writeFile gpgconf $ unlines [ " keyring " ++ keyring , "no-auto-check-trustdb" @@ -38,6 +38,7 @@ oldsha <- getCurrentGitSha1 branchref + keyring <- privDataKeyring whenM (doesFileExist keyring) $ ifM (verifyOriginBranch originbranch) ( do diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -1,13 +1,10 @@ module Propellor.Gpg where import System.IO -import System.FilePath import System.Directory import Data.Maybe import Data.List.Utils import Control.Monad -import System.Console.Concurrent -import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import Control.Applicative import Prelude @@ -16,6 +13,7 @@ import Propellor.Git.Config import Utility.SafeCommand import Utility.Process +import Utility.Process.NonConcurrent import Utility.Monad import Utility.Misc import Utility.Tmp @@ -31,22 +29,21 @@ Nothing -> getEnvDefault "GNUPGBIN" "gpg" Just b -> return b -keyring :: FilePath -keyring = privDataDir "keyring.gpg" - -- Lists the keys in propellor's keyring. listPubKeys :: IO [KeyId] listPubKeys = do gpgbin <- getGpgBin - parse . lines <$> readProcess gpgbin listopts + keyring <- privDataKeyring + parse . lines <$> readProcess gpgbin (listopts keyring) where - listopts = useKeyringOpts ++ ["--with-colons", "--list-public-keys"] + listopts keyring = useKeyringOpts keyring ++ + ["--with-colons", "--list-public-keys"] parse = mapMaybe (keyIdField . split ":") keyIdField ("pub":_:_:_:f:_) = Just f keyIdField _ = Nothing -useKeyringOpts :: [String] -useKeyringOpts = +useKeyringOpts :: FilePath -> [String] +useKeyringOpts keyring = [ "--options" , "/dev/null" , "--no-default-keyring" @@ -56,20 +53,21 @@ addKey :: KeyId -> IO () addKey keyid = do gpgbin <- getGpgBin + keyring <- privDataKeyring exitBool =<< allM (uncurry actionMessage) - [ ("adding key to propellor's keyring", addkeyring gpgbin) + [ ("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 gpgbin' = do + addkeyring keyring' gpgbin' = do createDirectoryIfMissing True privDataDir boolSystem "sh" [ Param "-c" , Param $ gpgbin' ++ " --export " ++ keyid ++ " | gpg " ++ - unwords (useKeyringOpts ++ ["--import"]) + unwords (useKeyringOpts keyring' ++ ["--import"]) ] gitconfig gpgbin' = ifM (snd <$> processTranscript gpgbin' ["--list-secret-keys", keyid] Nothing) @@ -86,16 +84,17 @@ rmKey :: KeyId -> IO () rmKey keyid = do gpgbin <- getGpgBin + keyring <- privDataKeyring exitBool =<< allM (uncurry actionMessage) - [ ("removing key from propellor's keyring", rmkeyring gpgbin) + [ ("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 gpgbin' = boolSystem gpgbin' $ - (map Param useKeyringOpts) ++ + rmkeyring keyring' gpgbin' = boolSystem gpgbin' $ + (map Param (useKeyringOpts keyring')) ++ [ Param "--batch" , Param "--yes" , Param "--delete-key", Param keyid @@ -111,12 +110,14 @@ ) reencryptPrivData :: IO Bool -reencryptPrivData = ifM (doesFileExist privDataFile) - ( do - gpgEncrypt privDataFile =<< gpgDecrypt privDataFile - gitAdd privDataFile - , return True - ) +reencryptPrivData = do + f <- privDataFile + ifM (doesFileExist f) + ( do + gpgEncrypt f =<< gpgDecrypt f + gitAdd f + , return True + ) gitAdd :: FilePath -> IO Bool gitAdd f = boolSystem "git" @@ -126,17 +127,21 @@ 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 [ privDataFile, keyring] + 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 = ifM (doesFileExist keyring) - ( return (ps ++ [Param "--gpg-sign"]) - , return ps - ) +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 @@ -144,12 +149,7 @@ let ps' = Param "commit" : ps ++ maybe [] (\m -> [Param "-m", Param m]) msg ps'' <- gpgSignParams ps' - if isNothing msg - then do - (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ - proc "git" (toCommand ps'') - checkSuccessProcess p - else boolSystem "git" ps'' + boolSystemNonConcurrent "git" ps'' gpgDecrypt :: FilePath -> IO String gpgDecrypt f = do diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -34,8 +34,6 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy as L -import System.Console.Concurrent -import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import Control.Applicative import Data.Monoid import Prelude @@ -52,12 +50,12 @@ 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.Process -- | Allows a Property to access the value of a specific PrivDataField, -- for use in a specific Context or HostContext. @@ -196,8 +194,7 @@ hClose th maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v editor <- getEnvDefault "EDITOR" "vi" - (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ proc editor [f] - unlessM (checkSuccessProcess p) $ + unlessM (boolSystemNonConcurrent editor [File f]) $ error "Editor failed; aborting." PrivData <$> readFile f setPrivDataTo field context v' @@ -254,12 +251,13 @@ makePrivDataDir m <- decryptPrivData let (m', r) = f m - gpgEncrypt privDataFile (show m') - void $ boolSystem "git" [Param "add", File privDataFile] + privdata <- privDataFile + gpgEncrypt privdata (show m') + void $ boolSystem "git" [Param "add", File privdata] return r decryptPrivData :: IO PrivMap -decryptPrivData = readPrivData <$> gpgDecrypt privDataFile +decryptPrivData = readPrivData <$> (gpgDecrypt =<< privDataFile) readPrivData :: String -> PrivMap readPrivData = fromMaybe M.empty . readish diff --git a/src/Propellor/PrivData/Paths.hs b/src/Propellor/PrivData/Paths.hs --- a/src/Propellor/PrivData/Paths.hs +++ b/src/Propellor/PrivData/Paths.hs @@ -1,15 +1,31 @@ module Propellor.PrivData.Paths where +import Utility.Exception import System.FilePath +import Control.Applicative +import Prelude privDataDir :: FilePath privDataDir = "privdata" -privDataFile :: FilePath -privDataFile = privDataDir "privdata.gpg" +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/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -20,6 +20,7 @@ , property , ensureProperty , withOS + , unsupportedOS , makeChange , noChange , doNothing @@ -256,9 +257,17 @@ -- > myproperty = withOS "foo installed" $ \o -> case o of -- > (Just (System (Debian suite) arch)) -> ... -- > (Just (System (Buntish release) arch)) -> ... --- > Nothing -> ... +-- > Nothing -> unsupportedOS withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo withOS desc a = property desc $ a =<< getOS + +-- | Throws an error, for use in `withOS` when a property is lacking +-- support for an OS. +unsupportedOS :: Propellor a +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 i -> RevertableProperty i diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -27,7 +27,7 @@ [ siteAvailable domain cf `requires` installed `onChange` reloaded - , check (not <$> isenabled) + , check (not <$> isenabled) (cmdProperty "a2ensite" ["--quiet", domain]) `requires` installed `onChange` reloaded @@ -37,7 +37,7 @@ siteDisabled :: Domain -> Property NoInfo siteDisabled domain = combineProperties - ("apache site disabled " ++ domain) + ("apache site disabled " ++ domain) (map File.notPresent (siteCfg domain)) `onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange) `requires` installed @@ -72,7 +72,7 @@ listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps `onChange` restarted where - portline (Port n) = "Listen " ++ show n + 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. @@ -82,7 +82,7 @@ [ "/etc/apache2/sites-available/" ++ domain -- Debian 2.4+ , "/etc/apache2/sites-available/" ++ domain ++ ".conf" - ] + ] -- | Configure apache to use SNI to differentiate between -- https hosts. @@ -130,13 +130,13 @@ -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file. Not https capable. virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo -virtualHost domain (Port p) docroot = virtualHost' domain (Port p) docroot [] +virtualHost domain port docroot = virtualHost' domain port docroot [] -- | Like `virtualHost` but with additional config lines added. virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo -virtualHost' domain (Port p) docroot addedcfg = siteEnabled domain $ - [ "" - , "ServerName "++domain++":"++show p +virtualHost' domain port docroot addedcfg = siteEnabled domain $ + [ "" + , "ServerName " ++ domain ++ ":" ++ fromPort port , "DocumentRoot " ++ docroot , "ErrorLog /var/log/apache2/error.log" , "LogLevel warn" @@ -201,9 +201,9 @@ , "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain ] sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf" - vhost (Port p) ls = - [ "" - , "ServerName "++domain++":"++show p + vhost p ls = + [ "" + , "ServerName " ++ domain ++ ":" ++ fromPort p , "DocumentRoot " ++ docroot , "ErrorLog /var/log/apache2/error.log" , "LogLevel warn" diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -123,10 +123,29 @@ `assume` MadeChange `describe` "apt update" +-- | Have apt upgrade packages, adding new packages and removing old as +-- necessary. upgrade :: Property NoInfo -upgrade = runApt ["-y", "dist-upgrade"] +upgrade = upgrade' "dist-upgrade" + +upgrade' :: String -> Property NoInfo +upgrade' p = combineProperties ("apt " ++ p) + [ 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 NoInfo +safeUpgrade = upgrade' "upgrade" + +-- | Have dpkg try to configure any packages that are not fully configured. +pendingConfigured :: Property NoInfo +pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv `assume` MadeChange - `describe` "apt dist-upgrade" + `describe` "dpkg configured pending" type Package = String @@ -135,22 +154,20 @@ installed' :: [String] -> [Package] -> Property NoInfo installed' params ps = robustly $ check (isInstallable ps) go - `describe` (unwords $ "apt installed":ps) + `describe` unwords ("apt installed":ps) where go = runApt (params ++ ["install"] ++ ps) installedBackport :: [Package] -> Property NoInfo installedBackport ps = withOS desc $ \o -> case o of - Nothing -> error "cannot install backports; os not declared" (Just (System (Debian suite) _)) -> case backportSuite suite of - Nothing -> notsupported o - Just bs -> ensureProperty $ + Nothing -> unsupportedOS + Just bs -> ensureProperty $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus - _ -> notsupported o + _ -> unsupportedOS where - desc = (unwords $ "apt installed backport":ps) - notsupported o = error $ "backports not supported on " ++ show o + desc = unwords ("apt installed backport":ps) -- | Minimal install of package, without recommends. installedMin :: [Package] -> Property NoInfo @@ -158,12 +175,12 @@ removed :: [Package] -> Property NoInfo removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) - `describe` (unwords $ "apt removed":ps) + `describe` unwords ("apt removed":ps) buildDep :: [Package] -> Property NoInfo buildDep ps = robustly $ go `changesFile` dpkgStatus - `describe` (unwords $ "apt build-dep":ps) + `describe` unwords ("apt build-dep":ps) where go = runApt $ ["-y", "build-dep"] ++ ps @@ -256,8 +273,8 @@ reConfigure package vals = reconfigure `requires` setselections `describe` ("reconfigure " ++ package) where - setselections = property "preseed" $ - if null vals + setselections = property "preseed" $ + if null vals then noChange else makeChange $ withHandle StdinHandle createProcessSuccess @@ -312,7 +329,7 @@ hasForeignArch arch = check notAdded (add `before` update) `describe` ("dpkg has foreign architecture " ++ arch) where - notAdded = (not . elem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"] + notAdded = (notElem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"] add = cmdProperty "dpkg" ["--add-architecture", arch] `assume` MadeChange diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -55,7 +55,7 @@ -- 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 + -- If the operating System is not supported, return -- Left error message. buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) @@ -91,6 +91,7 @@ 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` property not specified" where debootstrap s = Debootstrap.built loc s cf @@ -102,8 +103,8 @@ -- -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" -- > & os (System (Debian Unstable) "amd64") --- > & Apt.installed ["ghc", "haskell-platform"] --- > & ... +-- > & Apt.installed ["ghc", "haskell-platform"] +-- > & ... debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot debootstrapped conf = bootstrapped (Debootstrapped conf) @@ -131,7 +132,7 @@ where setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly `requires` toProp built - + built = case buildchroot bootstrapper (chrootSystem c) loc of Right p -> p Left e -> cantbuild e @@ -152,7 +153,7 @@ (propertyChildren p) chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ h) = mempty `addInfo` +chrootInfo (Chroot loc _ h) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. @@ -201,7 +202,7 @@ return $ ChrootChain parenthost loc systemdonly onconsole chain :: [Host] -> CmdLine -> IO () -chain hostlist (ChrootChain hn loc systemdonly onconsole) = +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 $ getInfo $ hostInfo parenthost) of @@ -230,7 +231,7 @@ -- /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 diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -21,7 +21,7 @@ -- | 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. @@ -47,7 +47,7 @@ , case times of Times _ -> doNothing _ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes) - -- Use a separate script because it makes the cron job name + -- 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" @@ -81,5 +81,7 @@ -- | Installs a cron job to run propellor. runPropellor :: Times -> Property NoInfo -runPropellor times = niceJob "propellor" times (User "root") localdir - (bootstrapPropellorCommand ++ "; ./propellor") +runPropellor times = withOS "propellor cron job" $ \o -> + ensureProperty $ + niceJob "propellor" times (User "root") localdir + (bootstrapPropellorCommand o ++ "; ./propellor") diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -23,7 +23,7 @@ type Url = String --- | A monoid for debootstrap configuration. +-- | A monoid for debootstrap configuration. -- mempty is a default debootstrapped system. data DebootstrapConfig = DefaultConfig @@ -34,8 +34,8 @@ deriving (Show) instance Monoid DebootstrapConfig where - mempty = DefaultConfig - mappend = (:+) + mempty = DefaultConfig + mappend = (:+) toParams :: DebootstrapConfig -> [CommandParam] toParams DefaultConfig = [] @@ -52,7 +52,7 @@ built target system config = built' (toProp installed) target system config built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) -built' installprop target system@(System _ arch) config = +built' installprop target system@(System _ arch) config = check (unpopulated target <||> ispartial) setupprop `requires` installprop where @@ -88,10 +88,11 @@ return True , return False ) - + 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. -- @@ -101,7 +102,7 @@ installed :: RevertableProperty NoInfo installed = install remove where - install = withOS "debootstrap installed" $ \o -> + install = withOS "debootstrap installed" $ \o -> ifM (liftIO $ isJust <$> programPath) ( return NoChange , ensureProperty (installon o) @@ -115,7 +116,7 @@ removefrom (Just (System (Debian _) _)) = aptremove removefrom (Just (System (Buntish _) _)) = aptremove removefrom _ = sourceRemove - + aptinstall = Apt.installed ["debootstrap"] aptremove = Apt.removed ["debootstrap"] @@ -273,9 +274,9 @@ _ -> findend l r collect l (_:cs) = collect l cs - findend l s = + findend l s = let (u, r) = break (== '"') s u' = if "http" `isPrefixOf` u - then u + then u else base u in collect (u':l) r diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -75,7 +75,7 @@ configured = prop `requires` installed where prop = withPrivData src anyContext $ \getcfg -> - property "docker configured" $ getcfg $ \cfg -> ensureProperty $ + property "docker configured" $ getcfg $ \cfg -> ensureProperty $ "/root/.dockercfg" `File.hasContent` privDataLines cfg src = PrivDataSourceFileFromCommand DockerAuthentication "/root/.dockercfg" "docker login" @@ -115,7 +115,7 @@ info = dockerInfo mempty -- | 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. -- @@ -186,7 +186,7 @@ cn = hostName h mkContainerInfo :: ContainerId -> Container -> ContainerInfo -mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = +mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = ContainerInfo img runparams where runparams = map (\(DockerRunParam mkparam) -> mkparam hn) @@ -233,7 +233,7 @@ `assume` NoChange `describe` "tweaked for docker" --- | Configures the kernel to respect docker memory limits. +-- | 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. @@ -241,7 +241,7 @@ -- Only takes effect after reboot. (Not automated.) memoryLimited :: Property NoInfo memoryLimited = "/etc/default/grub" `File.containsLine` cfg - `describe` "docker memory limited" + `describe` "docker memory limited" `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) where cmdline = "cgroup_enable=memory swapaccount=1" @@ -315,7 +315,7 @@ toPublish :: p -> String instance Publishable (Bound Port) where - toPublish p = show (hostSide p) ++ ":" ++ show (containerSide p) + toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p) -- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort instance Publishable String where @@ -355,7 +355,7 @@ volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) --- | Work dir inside the container. +-- | Work dir inside the container. workdir :: String -> Property HasInfo workdir = runProp "workdir" @@ -409,7 +409,7 @@ -- | A container is identified by its name, and the host -- on which it's deployed. -data ContainerId = ContainerId +data ContainerId = ContainerId { containerHostName :: HostName , containerName :: ContainerName } @@ -503,7 +503,7 @@ v <- a case v of Right Nothing -> do - threadDelaySeconds (Seconds 1) + threadDelaySeconds (Seconds 1) retry (n-1) a _ -> return v @@ -569,7 +569,7 @@ r <- withHandle StdoutHandle createProcessSuccess p $ processChainOutput when (r /= FailedChange) $ - setProvisionedFlag cid + setProvisionedFlag cid return r toChain :: ContainerId -> CmdLine @@ -600,9 +600,9 @@ startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] stoppedContainer :: ContainerId -> Property NoInfo -stoppedContainer cid = containerDesc cid $ property desc $ +stoppedContainer cid = containerDesc cid $ property desc $ ifM (liftIO $ elem cid <$> listContainers RunningContainers) - ( liftIO cleanup `after` ensureProperty + ( liftIO cleanup `after` ensureProperty (property desc $ liftIO $ toResult <$> stopContainer cid) , return NoChange ) @@ -638,7 +638,7 @@ -- | Only lists propellor managed containers. listContainers :: ContainerFilter -> IO [ContainerId] -listContainers status = +listContainers status = mapMaybe toContainerId . concatMap (split ",") . mapMaybe (lastMaybe . words) . lines <$> readProcess dockercmd ps diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -7,14 +7,13 @@ installed, Chain(..), Table(..), - TargetFilter(..), - TargetNat(..), - TargetMangle(..), - TargetRaw(..), - TargetSecurity(..), + Target(..), Proto(..), Rules(..), ConnectionState(..), + ICMPTypeMatch(..), + TCPFlag(..), + Frequency(..), IPWithMask(..), fromIPWithMask ) where @@ -30,10 +29,10 @@ installed :: Property NoInfo installed = Apt.installed ["iptables"] -rule :: Chain -> Table -> Rules -> Property NoInfo -rule c t rs = property ("firewall rule: " <> show r) addIpTable +rule :: Chain -> Table -> Target -> Rules -> Property NoInfo +rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable where - r = Rule c t rs + r = Rule c tb tg rs addIpTable = liftIO $ do let args = toIpTable r exist <- boolSystem "iptables" (chk args) @@ -45,15 +44,16 @@ toIpTable :: Rule -> [CommandParam] toIpTable r = map Param $ - show (ruleChain r) : - toIpTableArg (ruleRules r) ++ toIpTableTable (ruleTable r) + 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 port)) = ["--dport", show port] -toIpTableArg (DPortRange (Port f, Port t)) = - ["--dport", show f ++ ":" ++ show t] +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) = @@ -61,6 +61,24 @@ , "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 (Source ipwm) = [ "-s" , intercalate "," (map fromIPWithMask ipwm) @@ -69,6 +87,10 @@ [ "-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 @@ -80,83 +102,67 @@ fromIPWithMask (IPWithNumMask ip m) = fromIPAddr ip ++ "/" ++ show m data Rule = Rule - { ruleChain :: Chain - , ruleTable :: Table - , ruleRules :: Rules + { ruleChain :: Chain + , ruleTable :: Table + , ruleTarget :: Target + , ruleRules :: Rules } deriving (Eq, Show) -data Table = Filter TargetFilter | Nat TargetNat | Mangle TargetMangle | Raw TargetRaw | Security TargetSecurity +data Table = Filter | Nat | Mangle | Raw | Security deriving (Eq, Show) -toIpTableTable :: Table -> [String] -toIpTableTable f = ["-t", table, "-j", target] - where - (table, target) = toIpTableTable' f - -toIpTableTable' :: Table -> (String, String) -toIpTableTable' (Filter target) = ("filter", fromTarget target) -toIpTableTable' (Nat target) = ("nat", fromTarget target) -toIpTableTable' (Mangle target) = ("mangle", fromTarget target) -toIpTableTable' (Raw target) = ("raw", fromTarget target) -toIpTableTable' (Security target) = ("security", fromTarget target) - -data Chain = INPUT | OUTPUT | FORWARD - deriving (Eq, Show) +fromTable :: Table -> String +fromTable Filter = "filter" +fromTable Nat = "nat" +fromTable Mangle = "mangle" +fromTable Raw = "raw" +fromTable Security = "security" -data TargetFilter = ACCEPT | REJECT | DROP | LOG | FilterCustom String +data Target = ACCEPT | REJECT | DROP | LOG | TargetCustom String deriving (Eq, Show) -class FromTarget a where - fromTarget :: a -> String - -instance FromTarget TargetFilter where - fromTarget ACCEPT = "ACCEPT" - fromTarget REJECT = "REJECT" - fromTarget DROP = "DROP" - fromTarget LOG = "LOG" - fromTarget (FilterCustom f) = f +fromTarget :: Target -> String +fromTarget ACCEPT = "ACCEPT" +fromTarget REJECT = "REJECT" +fromTarget DROP = "DROP" +fromTarget LOG = "LOG" +fromTarget (TargetCustom t) = t -data TargetNat = NatPREROUTING | NatOUTPUT | NatPOSTROUTING | NatCustom String +data Chain = INPUT | OUTPUT | FORWARD | PREROUTING | POSTROUTING | ChainCustom String deriving (Eq, Show) -instance FromTarget TargetNat where - fromTarget NatPREROUTING = "PREROUTING" - fromTarget NatOUTPUT = "OUTPUT" - fromTarget NatPOSTROUTING = "POSTROUTING" - fromTarget (NatCustom f) = f +fromChain :: Chain -> String +fromChain INPUT = "INPUT" +fromChain OUTPUT = "OUTPUT" +fromChain FORWARD = "FORWARD" +fromChain PREROUTING = "PREROUTING" +fromChain POSTROUTING = "POSTROUTING" +fromChain (ChainCustom c) = c -data TargetMangle = ManglePREROUTING | MangleOUTPUT | MangleINPUT | MangleFORWARD | ManglePOSTROUTING | MangleCustom String +data Proto = TCP | UDP | ICMP deriving (Eq, Show) -instance FromTarget TargetMangle where - fromTarget ManglePREROUTING = "PREROUTING" - fromTarget MangleOUTPUT = "OUTPUT" - fromTarget MangleINPUT = "INPUT" - fromTarget MangleFORWARD = "FORWARD" - fromTarget ManglePOSTROUTING = "POSTROUTING" - fromTarget (MangleCustom f) = f +data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID + deriving (Eq, Show) -data TargetRaw = RawPREROUTING | RawOUTPUT | RawCustom String +data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int deriving (Eq, Show) -instance FromTarget TargetRaw where - fromTarget RawPREROUTING = "PREROUTING" - fromTarget RawOUTPUT = "OUTPUT" - fromTarget (RawCustom f) = f +fromICMPTypeMatch :: ICMPTypeMatch -> String +fromICMPTypeMatch (ICMPTypeName t) = t +fromICMPTypeMatch (ICMPTypeCode c) = show c -data TargetSecurity = SecurityINPUT | SecurityOUTPUT | SecurityFORWARD | SecurityCustom String +data Frequency = NumBySecond Int deriving (Eq, Show) -instance FromTarget TargetSecurity where - fromTarget SecurityINPUT = "INPUT" - fromTarget SecurityOUTPUT = "OUTPUT" - fromTarget SecurityFORWARD = "FORWARD" - fromTarget (SecurityCustom f) = f +fromFrequency :: Frequency -> String +fromFrequency (NumBySecond n) = show n ++ "/second" -data Proto = TCP | UDP | ICMP - deriving (Eq, Show) +type TCPFlagMask = [TCPFlag] -data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID +type TCPFlagComp = [TCPFlag] + +data TCPFlag = SYN | ACK | FIN | RST | URG | PSH | ALL | NONE deriving (Eq, Show) data Rules @@ -165,12 +171,17 @@ -- ^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) + | DPortRange (Port, Port) | InIFace Network.Interface | OutIFace Network.Interface | Ctstate [ ConnectionState ] + | ICMPType ICMPTypeMatch + | RateLimit Frequency + | TCPFlags TCPFlagMask TCPFlagComp + | TCPSyn | Source [ IPWithMask ] | Destination [ IPWithMask ] + | NatDestination IPAddr (Maybe Port) | Rules :- Rules -- ^Combine two rules deriving (Eq, Show) diff --git a/src/Propellor/Property/FreeBSD.hs b/src/Propellor/Property/FreeBSD.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/FreeBSD.hs @@ -0,0 +1,13 @@ +-- | Maintainer: 2016 Evan Cofsky +-- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -0,0 +1,85 @@ +-- | Maintainer: 2016 Evan Cofsky +-- +-- 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 NoInfo +pkgCmdProperty cmd args = + 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 +update = + let + upd = pkgCmd "update" [] + go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) + in + infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) [] + +newtype PkgUpgrade = PkgUpgrade String + deriving (Typeable, Monoid, Show) +instance IsInfo PkgUpgrade where + propagateInfo _ = False + +pkgUpgraded :: PkgUpgrade -> Bool +pkgUpgraded (PkgUpgrade _) = True + +upgrade :: Property HasInfo +upgrade = + let + upd = pkgCmd "upgrade" [] + go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) + in + infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update + +type Package = String + +installed :: Package -> Property NoInfo +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 new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/FreeBSD/Poudriere.hs @@ -0,0 +1,141 @@ +-- | Maintainer: 2016 Evan Cofsky +-- +-- FreeBSD Poudriere properties + +{-# Language GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Propellor.Property.FreeBSD.Poudriere where + +import Propellor.Base +import Propellor.Types.Info +import Data.List +import Data.String (IsString(..)) + +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 +setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "") + +poudriere :: Poudriere -> Property HasInfo +poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop + `requires` Pkg.installed "poudriere" + `before` setConfigured + where + confProp = File.containsLines poudriereConfigPath (toLines conf) + setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS" + prop :: CombinedType (Property NoInfo) (Property NoInfo) + prop + | isJust zfs = ((setZfs $ fromJust zfs) `before` confProp) + | otherwise = propertyList "Configuring Poudriere without ZFS" [confProp] + +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 NoInfo +jail j@(Jail name version arch) = + 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" + +instance IsString PoudriereArch where + fromString "i386" = I386 + fromString "amd64" = AMD64 + fromString _ = 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/Locale.hs b/src/Propellor/Property/Locale.hs --- a/src/Propellor/Property/Locale.hs +++ b/src/Propellor/Property/Locale.hs @@ -57,7 +57,7 @@ if locale `presentIn` locales then ensureProperty $ fileProperty desc (foldr uncomment []) f - `onChange` regenerate + `onChange` regenerate else return FailedChange -- locale unavailable for generation ensureUnavailable = fileProperty (locale ++ " locale not generated") (foldr comment []) f @@ -75,6 +75,5 @@ l `presentIn` ls = any (l `isPrefix`) ls l `isPrefix` x = (l `isPrefixOf` x) || (("# " ++ l) `isPrefixOf` x) - regenerate = cmdProperty "dpkg-reconfigure" - ["-f", "noninteractive", "locales"] + regenerate = cmdProperty "locale-gen" [] `assume` MadeChange diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -3,6 +3,8 @@ import Propellor.Base import Propellor.Property.File +import Data.Char + type Interface = String ifUp :: Interface -> Property NoInfo @@ -45,7 +47,7 @@ -- -- If the interface file already exists, this property does nothing, -- no matter its content. --- +-- -- (ipv6 addresses are not included because it's assumed they come up -- automatically in most situations.) static :: Interface -> Property NoInfo @@ -97,7 +99,12 @@ -- | A file in the interfaces.d directory. interfaceDFile :: Interface -> FilePath -interfaceDFile iface = "/etc/network/interfaces.d" iface +interfaceDFile i = "/etc/network/interfaces.d" escapeInterfaceDName i + +-- | /etc/network/interfaces.d/ files have to match -- ^[a-zA-Z0-9_-]+$ +-- see "man 5 interfaces" +escapeInterfaceDName :: Interface -> FilePath +escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-")) -- | Ensures that files in the the interfaces.d directory are used. interfacesDEnabled :: Property NoInfo diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -86,7 +86,7 @@ osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of (Just d@(System (Debian _) _)) -> debootstrap d (Just u@(System (Buntish _) _)) -> debootstrap u - _ -> error "os is not declared to be Debian or *buntu" + _ -> unsupportedOS debootstrap targetos = ensureProperty $ -- Ignore the os setting, and install debootstrap from diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs --- a/src/Propellor/Property/OpenId.hs +++ b/src/Propellor/Property/OpenId.hs @@ -28,21 +28,21 @@ where baseurl = hn ++ case mp of Nothing -> "" - Just (Port p) -> ':' : show p + Just p -> ':' : fromPort p url = "http://"++baseurl++"/simpleid" desc = "openid provider " ++ url setbaseurl l - | "SIMPLEID_BASE_URL" `isInfixOf` l = + | "SIMPLEID_BASE_URL" `isInfixOf` l = "define('SIMPLEID_BASE_URL', '"++url++"');" | otherwise = l - + apacheconfigured = case mp of Nothing -> toProp $ Apache.virtualHost hn (Port 80) "/var/www/html" Just p -> propertyList desc $ props & Apache.listenPorts [p] & Apache.virtualHost hn p "/var/www/html" - + -- the identities directory controls access, so open up -- file mode identfile (User u) = File.hasPrivContentExposed diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -80,7 +80,7 @@ "liblockfile-simple-perl", "cabal-install", "vim", "less", -- needed by haskell libs "libxml2-dev", "libidn11-dev", "libgsasl7-dev", "libgnutls28-dev", - "alex", "happy", "c2hs" + "libmagic-dev", "alex", "happy", "c2hs" ] haskellPkgsInstalled :: String -> Property NoInfo @@ -105,7 +105,6 @@ autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout = Systemd.container name osver (Chroot.debootstrapped mempty) & mkprop osver flavor - & buildDepsApt & autobuilder arch crontime timeout where name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder" @@ -116,11 +115,48 @@ standardAutoBuilder osver@(System _ arch) flavor = propertyList "standard git-annex autobuilder" $ props & os osver + & buildDepsApt & Apt.stdSourcesList & Apt.unattendedUpgrades & Apt.cacheCleaned & User.accountFor (User builduser) & tree arch flavor + +stackAutoBuilder :: System -> Flavor -> Property HasInfo +stackAutoBuilder osver@(System _ arch) flavor = + propertyList "git-annex autobuilder using stack" $ props + & os osver + & buildDepsNoHaskellLibs + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & Apt.cacheCleaned + & User.accountFor (User builduser) + & tree arch flavor + & stackInstalled + +stackInstalled :: Property NoInfo +stackInstalled = withOS "stack installed" $ \o -> + case o of + (Just (System (Debian (Stable "jessie")) "i386")) -> + ensureProperty $ manualinstall "i386" + _ -> ensureProperty $ Apt.installed ["haskell-stack"] + where + -- Warning: Using a binary downloaded w/o validation. + manualinstall arch = check (not <$> doesFileExist binstack) $ + propertyList "stack installed from upstream tarball" + [ cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar] + `assume` MadeChange + , File.dirExists tmpdir + , cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"] + `assume` MadeChange + , cmdProperty "mv" [tmpdir "stack", binstack] + `assume` MadeChange + , cmdProperty "rm" ["-rf", tmpdir, tmptar] + `assume` MadeChange + ] + binstack = "/usr/bin/stack" + tmptar = "/root/stack.tar.gz" + tmpdir = "/root/stack" armAutoBuilder :: System -> Flavor -> Property HasInfo armAutoBuilder osver flavor = diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -75,7 +75,7 @@ | s == cfgline = True | (setting ++ " ") `isPrefixOf` s = False | otherwise = True - f ls + f ls | cfgline `elem` ls = filter wantedline ls | otherwise = filter wantedline ls ++ [cfgline] @@ -94,7 +94,7 @@ -- | Configure ssh to not allow password logins. -- --- To prevent lock-out, this is done only once root's +-- To prevent lock-out, this is done only once root's -- authorized_keys is in place. noPasswords :: Property NoInfo noPasswords = check (hasAuthorizedKeys (User "root")) $ @@ -114,10 +114,10 @@ -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. -listenPort :: Int -> RevertableProperty NoInfo +listenPort :: Port -> RevertableProperty NoInfo listenPort port = enable disable where - portline = "Port " ++ show port + portline = "Port " ++ fromPort port enable = sshdConfig `File.containsLine` portline `describe` ("ssh listening on " ++ portline) `onChange` restarted @@ -173,7 +173,7 @@ -- | Installs a single ssh host key of a particular type. -- -- The public key is provided to this function; --- the private key comes from the privdata; +-- the private key comes from the privdata; hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo hostKey context keytype pub = combineProperties desc [ hostPubKey keytype pub @@ -210,7 +210,7 @@ getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) getHostPubKey = fromHostKeyInfo <$> askInfo -newtype HostKeyInfo = HostKeyInfo +newtype HostKeyInfo = HostKeyInfo { fromHostKeyInfo :: M.Map SshKeyType PubKeyText } deriving (Eq, Ord, Typeable, Show) @@ -219,7 +219,7 @@ instance Monoid HostKeyInfo where mempty = HostKeyInfo M.empty - mappend (HostKeyInfo old) (HostKeyInfo new) = + mappend (HostKeyInfo old) (HostKeyInfo new) = -- new first because union prefers values from the first -- parameter when there is a duplicate key HostKeyInfo (new `M.union` old) @@ -240,12 +240,12 @@ instance Monoid UserKeyInfo where mempty = UserKeyInfo M.empty - mappend (UserKeyInfo old) (UserKeyInfo new) = + mappend (UserKeyInfo old) (UserKeyInfo new) = UserKeyInfo (M.unionWith S.union old new) -- | Sets up a user with the specified public keys, and the corresponding -- private keys from the privdata. --- +-- -- The public keys are added to the Info, so other properties like -- `authorizedKeysFrom` can use them. userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo @@ -277,7 +277,7 @@ , Just $ "(" ++ fromKeyType keytype ++ ")" ] pubkey = property desc $ install File.hasContent ".pub" [pubkeytext] - privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> + privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> property desc $ getkey $ install File.hasContentProtected "" . privDataLines install writer ext key = do @@ -349,7 +349,7 @@ -- -- Any other lines in the authorized_keys file are preserved as-is. authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo -localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = +localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = property desc (go =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost @@ -372,9 +372,9 @@ go [] = return NoChange go ls = ensureProperty $ combineProperties desc $ map (revert . authorizedKey localuser) ls - + authorizedKeyLines :: User -> Host -> Propellor [File.Line] -authorizedKeyLines remoteuser remotehost = +authorizedKeyLines remoteuser remotehost = map snd <$> fromHost' remotehost (getUserPubKeys remoteuser) -- | Makes a user have authorized_keys from the PrivData @@ -404,7 +404,7 @@ `requires` File.dirExists (takeDirectory f) remove = property (u ++ " lacks authorized_keys") $ do f <- liftIO $ dotFile "authorized_keys" user - ifM (liftIO $ doesFileExist f) + ifM (liftIO $ doesFileExist f) ( modAuthorizedKey f user $ f `File.lacksLine` l , return NoChange ) diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -127,7 +127,7 @@ -- | Enables persistent storage of the journal. persistentJournal :: Property NoInfo -persistentJournal = check (not <$> doesDirectoryExist dir) $ +persistentJournal = check (not <$> doesDirectoryExist dir) $ combineProperties "persistent systemd journal" [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] `assume` MadeChange @@ -145,7 +145,7 @@ -- Does not ensure that the relevant daemon notices the change immediately. -- -- This assumes that there is only one [Header] per file, which is --- currently the case for files like journald.conf and system.conf. +-- currently the case for files like journald.conf and system.conf. -- And it assumes the file already exists with -- the right [Header], so new lines can just be appended to the end. configured :: FilePath -> Option -> String -> Property NoInfo @@ -174,15 +174,13 @@ -- | Ensures machined and machinectl are installed machined :: Property NoInfo -machined = go `describe` "machined installed" - where - go = withOS ("standard sources.list") $ \o -> - case o of - -- Split into separate debian package since systemd 225. - (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty $ - Apt.installed ["systemd-container"] - _ -> noChange +machined = withOS "machined installed" $ \o -> + case o of + -- Split into separate debian package since systemd 225. + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty $ + Apt.installed ["systemd-container"] + _ -> noChange -- | Defines a container with a given machine name, and operating system, -- and how to create its chroot if not already present. @@ -232,7 +230,7 @@ -- Use nsenter to enter container and and run propellor to -- finish provisioning. - containerprovisioned = + containerprovisioned = Chroot.propellChroot chroot (enterContainerProcess c) False doNothing @@ -261,7 +259,7 @@ , "--machine=%i" ] ++ nspawnServiceParams cfg | otherwise = l - + goodservicefile = (==) <$> servicefilecontent <*> catchDefaultIO "" (readFile servicefile) @@ -368,7 +366,7 @@ toPublish :: a -> String instance Publishable Port where - toPublish (Port n) = show n + toPublish port = fromPort port instance Publishable (Bound Port) where toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v) @@ -380,7 +378,7 @@ toPublish (UDP, fp) = "udp:" ++ toPublish fp -- | Publish a port from the container to the host. --- +-- -- This feature was first added in systemd version 220. -- -- This property is only needed (and will only work) if the container diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs --- a/src/Propellor/Property/Tor.hs +++ b/src/Propellor/Property/Tor.hs @@ -54,17 +54,31 @@ torPrivKey :: Context -> Property HasInfo torPrivKey context = f `File.hasPrivContent` context `onChange` File.ownerGroup f user (userGroup user) - -- install tor first, so the directory exists with right perms - `requires` Apt.installed ["tor"] + `requires` torPrivKeyDirExists where - f = "/var/lib/tor/keys/secret_id_key" + f = torPrivKeyDir "secret_id_key" +torPrivKeyDirExists :: Property NoInfo +torPrivKeyDirExists = File.dirExists torPrivKeyDir + `onChange` setperms + `requires` installed + where + setperms = File.ownerGroup torPrivKeyDir user (userGroup user) + `before` File.mode torPrivKeyDir 0O2700 + +torPrivKeyDir :: FilePath +torPrivKeyDir = "/var/lib/tor/keys" + -- | A tor server (bridge, relay, or exit) -- Don't use if you just want to run tor for personal use. server :: Property NoInfo server = configured [("SocksPort", "0")] - `requires` Apt.installed ["tor", "ntp"] + `requires` installed + `requires` Apt.installed ["ntp"] `describe` "tor server" + +installed :: Property NoInfo +installed = Apt.installed ["tor"] -- | Specifies configuration settings. Any lines in the config file -- that set other values for the specified settings will be removed, diff --git a/src/Propellor/Property/ZFS.hs b/src/Propellor/Property/ZFS.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/ZFS.hs @@ -0,0 +1,11 @@ +-- | Maintainer: 2016 Evan Cofsky +-- +-- ZFS properties + +module Propellor.Property.ZFS ( + module Propellor.Property.ZFS.Properties, + module Propellor.Types.ZFS +) where + +import Propellor.Property.ZFS.Properties +import Propellor.Types.ZFS diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/ZFS/Process.hs @@ -0,0 +1,32 @@ +-- | Maintainer: 2016 Evan Cofsky +-- +-- Functions running zfs processes. + +module Propellor.Property.ZFS.Process where + +import Propellor.Base +import Data.String.Utils (split) +import Data.List + +-- | Gets the properties of a ZFS volume. +zfsGetProperties :: ZFS -> IO ZFSProperties +zfsGetProperties z = + let plist = fromPropertyList . map (\(_:k:v:_) -> (k, v)) . (map (split "\t")) + in plist <$> runZfs "get" [Just "-H", Just "-p", Just "all"] z + +zfsExists :: ZFS -> IO Bool +zfsExists z = any id . map (isInfixOf (zfsName z)) + <$> runZfs "list" [Just "-H"] z + +-- | Runs the zfs command with the arguments. +-- +-- Runs the command with -H which will skip the header line and +-- separate all fields with tabs. +-- +-- Replaces Nothing in the argument list with the ZFS pool/dataset. +runZfs :: String -> [Maybe String] -> ZFS -> IO [String] +runZfs cmd args z = lines <$> uncurry readProcess (zfsCommand cmd args z) + +-- | Return the ZFS command line suitable for readProcess or cmdProperty. +zfsCommand :: String -> [Maybe String] -> ZFS -> (String, [String]) +zfsCommand cmd args z = ("zfs", cmd:(map (maybe (zfsName z) id) args)) diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/ZFS/Properties.hs @@ -0,0 +1,36 @@ +-- | Maintainer: 2016 Evan Cofsky +-- +-- Functions defining zfs Properties. + +module Propellor.Property.ZFS.Properties ( + zfsExists, + zfsSetProperties +) where + +import Propellor.Base +import Data.List (intercalate) +import qualified Propellor.Property.ZFS.Process as ZP + +-- | Will ensure that a ZFS volume exists with the specified mount point. +-- This requires the pool to exist as well, but we don't create pools yet. +zfsExists :: ZFS -> Property NoInfo +zfsExists z = check (not <$> ZP.zfsExists z) create + `describe` unwords ["Creating", zfsName z] + where + (p, a) = ZP.zfsCommand "create" [Nothing] z + create = cmdProperty p a + +-- | Sets the given properties. Returns True if all were successfully changed, False if not. +zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo +zfsSetProperties z setProperties = setall + `requires` zfsExists z + where + spcmd :: String -> String -> (String, [String]) + spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z + + setprop :: (String, String) -> Property NoInfo + setprop (p, v) = check (ZP.zfsExists z) $ + cmdProperty (fst (spcmd p v)) (snd (spcmd p v)) + + setall = combineProperties (unwords ["Setting properties on", zfsName z]) $ + map setprop $ toPropertyList setProperties diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -1,3 +1,5 @@ +{-# Language ScopedTypeVariables #-} + module Propellor.Spin ( commitSpin, spin, @@ -30,6 +32,7 @@ import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand +import Utility.Process.NonConcurrent commitSpin :: IO () commitSpin = do @@ -41,7 +44,7 @@ currentBranch <- getCurrentBranch when (b /= currentBranch) $ error ("spin aborted: check out " - ++ b ++ " branch first") + ++ b ++ " branch first") -- safety check #2: check we can commit with a dirty tree noDirtySpin <- getGitConfigBool "propellor.forbid-dirty-spin" @@ -52,14 +55,14 @@ error "spin aborted: commit changes first" void $ actionMessage "Git commit" $ - gitCommit (Just spinCommitMessage) + gitCommit (Just spinCommitMessage) [Param "--allow-empty", Param "-a"] -- Push to central origin repo first, if possible. -- The remote propellor will pull from there, which avoids -- us needing to send stuff directly to the remote host. whenM hasOrigin $ void $ actionMessage "Push to central git repository" $ - boolSystem "git" [Param "push"] + boolSystemNonConcurrent "git" [Param "push"] spin :: Maybe HostName -> HostName -> Host -> IO () spin = spin' Nothing @@ -83,27 +86,30 @@ =<< getprivdata -- And now we can run it. - unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ + unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ error "remote propellor failed" where hn = fromMaybe target relay + sys = case getInfo (hostInfo hst) of + InfoVal o -> Just o + NoInfoVal -> Nothing relaying = relay == Just target viarelay = isJust relay && not relaying probecmd = intercalate " ; " - [ "if [ ! -d " ++ localdir ++ "/.git ]" + ["if [ ! -d " ++ localdir ++ "/.git ]" , "then (" ++ intercalate " && " - [ installGitCommand + [ installGitCommand sys , "echo " ++ toMarked statusMarker (show NeedGitClone) ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) , "else " ++ updatecmd , "fi" ] - + updatecmd = intercalate " && " [ "cd " ++ localdir - , bootstrapPropellorCommand + , bootstrapPropellorCommand sys , if viarelay then "./propellor --continue " ++ shellEscape (show (Relay target)) @@ -112,10 +118,11 @@ ] runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd - cmd = if viarelay - then "--serialized " ++ shellEscape (show (Spin [target] (Just target))) - else "--continue " ++ shellEscape (show (SimpleRun target)) - + cmd = "--serialized " ++ shellEscape (show cmdline) + cmdline + | viarelay = Spin [target] (Just target) + | otherwise = SimpleRun target + getprivdata = case mprivdata of Nothing | relaying -> do @@ -123,12 +130,12 @@ d <- readPrivDataFile f nukeFile f return d - | otherwise -> + | otherwise -> filterPrivData hst <$> decryptPrivData Just pd -> pure pd -- Check if the Host contains an IP address that matches one of the IPs --- in the DNS for the HostName. If so, the HostName is used as-is, +-- in the DNS for the HostName. If so, the HostName is used as-is, -- but if the DNS is out of sync with the Host config, or doesn't have -- the host in it at all, use one of the Host's IPs instead. getSshTarget :: HostName -> Host -> IO String @@ -186,9 +193,9 @@ hClose stdout -- Not using git pull because git 2.5.0 badly -- broke its option parser. - unlessM (boolSystem "git" (pullparams hin hout)) $ + unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $ errorMessage "git fetch from client failed" - unlessM (boolSystem "git" [Param "merge", Param "FETCH_HEAD"]) $ + unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $ errorMessage "git merge from client failed" where pullparams hin hout = @@ -198,7 +205,7 @@ , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout , Param "." ] - + -- When --spin --relay is run, get a privdata file -- to be relayed to the target host. privfile = maybe privDataLocal privDataRelay forhost @@ -211,8 +218,13 @@ -> CreateProcess -> PrivMap -> IO () -updateServer target relay hst connect haveprecompiled privdata = - withIOHandles createProcessSuccess connect go +updateServer target relay hst connect haveprecompiled privdata = do + (Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect + { std_in = CreatePipe + , std_out = CreatePipe + } + go (toh, fromh) + forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid where hn = fromMaybe target relay @@ -275,8 +287,8 @@ cacheparams <- sshCachingParams hn withTmpFile "propellor.git" $ \tmp _ -> allM id [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] - , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] + , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] + , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] ] where remotebundle = "/usr/local/propellor.git" @@ -312,8 +324,8 @@ withTmpFile "propellor.tar." $ \tarball _ -> allM id [ boolSystem "strip" [File me] , boolSystem "tar" [Param "czf", File tarball, File shimdir] - , boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] + , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] + , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] ] remotetarball = "/usr/local/propellor.tar" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -34,6 +34,7 @@ , module Propellor.Types.OS , module Propellor.Types.Dns , module Propellor.Types.Result + , module Propellor.Types.ZFS , propertySatisfy , ignoreInfo ) where @@ -49,6 +50,7 @@ import Propellor.Types.OS import Propellor.Types.Dns import Propellor.Types.Result +import Propellor.Types.ZFS -- | Everything Propellor knows about a system: Its hostname, -- properties and their collected info. @@ -126,7 +128,7 @@ type instance CInfo NoInfo NoInfo = NoInfo -- | Constructs a Property with associated Info. -infoProperty +infoProperty :: Desc -- ^ description of the property -> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly) -> Info -- ^ info associated with the property @@ -158,7 +160,7 @@ propertySatisfy (IProperty _ a _ _) = a propertySatisfy (SProperty _ a _) = a --- | Changes the action that is performed to satisfy a property. +-- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs @@ -172,7 +174,7 @@ propertyDesc (SProperty d _ _) = d instance Show (Property i) where - show p = "property " ++ show (propertyDesc p) + show p = "property " ++ show (propertyDesc p) -- | A Property can include a list of child properties that it also -- satisfies. This allows them to be introspected to collect their info, etc. @@ -188,7 +190,7 @@ } instance Show (RevertableProperty i) where - show (RevertableProperty p _) = show p + show (RevertableProperty p _) = show p class MkRevertableProperty i1 i2 where -- | Shorthand to construct a revertable property. @@ -216,7 +218,7 @@ setDesc (IProperty _ a i cs) d = IProperty d a i cs toProp = id getDesc = propertyDesc - getInfoRecursive (IProperty _ _ i cs) = + getInfoRecursive (IProperty _ _ i cs) = i <> mconcat (map getInfoRecursive cs) instance IsProp (Property NoInfo) where setDesc (SProperty _ a cs) d = SProperty d a cs @@ -256,8 +258,8 @@ class Combines x y where -- | Combines together two properties, yielding a property that -- has the description and info of the first, and that has the second - -- property as a child. - combineWith + -- property as a child. + combineWith :: ResultCombiner -- ^ How to combine the actions to satisfy the properties. -> ResultCombiner @@ -308,7 +310,7 @@ instance Combines (Property NoInfo) (RevertableProperty HasInfo) where combineWith = combineWithPR -combineWithRR +combineWithRR :: Combines (Property x) (Property y) => ResultCombiner -> ResultCombiner diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -4,6 +4,8 @@ System(..), Distribution(..), DebianSuite(..), + FreeBSDRelease(..), + FBSDVersion(..), isStable, Release, Architecture, @@ -13,10 +15,12 @@ Group(..), userGroup, Port(..), + fromPort, ) where import Network.BSD (HostName) import Data.Typeable +import Data.String -- | High level description of a operating system. data System = System Distribution Architecture @@ -25,6 +29,7 @@ data Distribution = Debian DebianSuite | Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per ) + | FreeBSD FreeBSDRelease deriving (Show, Eq) -- | Debian has several rolling suites, and a number of stable releases, @@ -32,6 +37,24 @@ data DebianSuite = Experimental | Unstable | Testing | Stable Release deriving (Show, Eq) +-- | FreeBSD breaks their releases into "Production" and "Legacy". +data FreeBSDRelease = FBSDProduction FBSDVersion | FBSDLegacy FBSDVersion + deriving (Show, Eq) + +data FBSDVersion = FBSD101 | FBSD102 | FBSD093 + deriving (Eq) + +instance IsString FBSDVersion where + fromString "10.1-RELEASE" = FBSD101 + fromString "10.2-RELEASE" = FBSD102 + fromString "9.3-RELEASE" = FBSD093 + fromString _ = error "Invalid FreeBSD release" + +instance Show FBSDVersion where + show FBSD101 = "10.1-RELEASE" + show FBSD102 = "10.2-RELEASE" + show FBSD093 = "9.3-RELEASE" + isStable :: DebianSuite -> Bool isStable (Stable _) = True isStable _ = False @@ -53,3 +76,6 @@ newtype Port = Port Int deriving (Eq, Show) + +fromPort :: Port -> String +fromPort (Port p) = show p diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/ZFS.hs @@ -0,0 +1,133 @@ +-- | Types for ZFS Properties. +-- +-- Copyright 2016 Evan Cofsky +-- License: BSD 2-clause + +module Propellor.Types.ZFS where + +import Data.String +import qualified Data.Set as Set +import qualified Data.String.Utils as SU +import Data.List + +-- | A single ZFS filesystem. +data ZFS = ZFS ZPool ZDataset deriving (Show, Eq, Ord) + +-- | Represents a zpool. +data ZPool = ZPool String deriving (Show, Eq, Ord) + +-- | Represents a dataset in a zpool. +-- +-- Can be constructed from a / separated string. +data ZDataset = ZDataset [String] deriving (Eq, Ord) + +type ZFSProperties = Set.Set ZFSProperty + +fromList :: [ZFSProperty] -> ZFSProperties +fromList = Set.fromList + +toPropertyList :: ZFSProperties -> [(String, String)] +toPropertyList = Set.foldr (\p l -> l ++ [toPair p]) [] + +fromPropertyList :: [(String, String)] -> ZFSProperties +fromPropertyList props = + Set.fromList $ map fromPair props + +zfsName :: ZFS -> String +zfsName (ZFS (ZPool pool) dataset) = intercalate "/" [pool, show dataset] + +instance Show ZDataset where + show (ZDataset paths) = intercalate "/" paths + +instance IsString ZDataset where + fromString s = ZDataset $ SU.split "/" s + +instance IsString ZPool where + fromString p = ZPool p + +class Value a where + toValue :: a -> String + fromValue :: (IsString a) => String -> a + fromValue = fromString + +data ZFSYesNo = ZFSYesNo Bool deriving (Show, Eq, Ord) +data ZFSOnOff = ZFSOnOff Bool deriving (Show, Eq, Ord) +data ZFSSize = ZFSSize Integer deriving (Show, Eq, Ord) +data ZFSString = ZFSString String deriving (Show, Eq, Ord) + +instance Value ZFSYesNo where + toValue (ZFSYesNo True) = "yes" + toValue (ZFSYesNo False) = "no" + +instance Value ZFSOnOff where + toValue (ZFSOnOff True) = "on" + toValue (ZFSOnOff False) = "off" + +instance Value ZFSSize where + toValue (ZFSSize s) = show s + +instance Value ZFSString where + toValue (ZFSString s) = s + +instance IsString ZFSString where + fromString = ZFSString + +instance IsString ZFSYesNo where + fromString "yes" = ZFSYesNo True + fromString "no" = ZFSYesNo False + fromString _ = error "Not yes or no" + +instance IsString ZFSOnOff where + fromString "on" = ZFSOnOff True + fromString "off" = ZFSOnOff False + fromString _ = error "Not on or off" + +data ZFSACLInherit = AIDiscard | AINoAllow | AISecure | AIPassthrough deriving (Show, Eq, Ord) +instance IsString ZFSACLInherit where + fromString "discard" = AIDiscard + fromString "noallow" = AINoAllow + fromString "secure" = AISecure + fromString "passthrough" = AIPassthrough + fromString _ = error "Not valid aclpassthrough value" + +instance Value ZFSACLInherit where + toValue AIDiscard = "discard" + toValue AINoAllow = "noallow" + toValue AISecure = "secure" + toValue AIPassthrough = "passthrough" + +data ZFSACLMode = AMDiscard | AMGroupmask | AMPassthrough deriving (Show, Eq, Ord) +instance IsString ZFSACLMode where + fromString "discard" = AMDiscard + fromString "groupmask" = AMGroupmask + fromString "passthrough" = AMPassthrough + fromString _ = error "Invalid zfsaclmode" + +instance Value ZFSACLMode where + toValue AMDiscard = "discard" + toValue AMGroupmask = "groupmask" + toValue AMPassthrough = "passthrough" + +data ZFSProperty = Mounted ZFSYesNo + | Mountpoint ZFSString + | ReadOnly ZFSYesNo + | ACLInherit ZFSACLInherit + | ACLMode ZFSACLMode + | StringProperty String ZFSString + deriving (Show, Eq, Ord) + +toPair :: ZFSProperty -> (String, String) +toPair (Mounted v) = ("mounted", toValue v) +toPair (Mountpoint v) = ("mountpoint", toValue v) +toPair (ReadOnly v) = ("readonly", toValue v) +toPair (ACLInherit v) = ("aclinherit", toValue v) +toPair (ACLMode v) = ("aclmode", toValue v) +toPair (StringProperty s v) = (s, toValue v) + +fromPair :: (String, String) -> ZFSProperty +fromPair ("mounted", v) = Mounted (fromString v) +fromPair ("mountpoint", v) = Mountpoint (fromString v) +fromPair ("readonly", v) = ReadOnly (fromString v) +fromPair ("aclinherit", v) = ACLInherit (fromString v) +fromPair ("aclmode", v) = ACLMode (fromString v) +fromPair (s, v) = StringProperty s (fromString v) diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -31,6 +31,7 @@ import qualified Data.Text.IO as T import Control.Applicative import Prelude +import System.Log.Logger import Utility.Monad import Utility.Exception @@ -114,21 +115,20 @@ withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput -- | Blocks until any processes started by `createProcessConcurrent` have --- finished, and any buffered output is displayed. +-- finished, and any buffered output is displayed. Also blocks while +-- `lockOutput` is is use. -- --- `withConcurrentOutput` calls this at the end; you can call it anytime --- you want to flush output. +-- `withConcurrentOutput` calls this at the end, so you do not normally +-- need to use this. flushConcurrentOutput :: IO () flushConcurrentOutput = do - -- Wait for all outputThreads to finish. - let v = outputThreads globalOutputHandle atomically $ do - r <- takeTMVar v + r <- takeTMVar (outputThreads globalOutputHandle) if r <= 0 - then putTMVar v r + then putTMVar (outputThreads globalOutputHandle) r else retry - -- Take output lock to ensure that nothing else is currently - -- generating output, and flush any buffered output. + -- Take output lock to wait for anything else that might be + -- currently generating output. lockOutput $ return () -- | Values that can be output. @@ -286,17 +286,31 @@ fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock + registerOutputThread + debug ["fgProcess", showProc p] -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h + unregisterOutputThread dropOutputLock + debug ["fgProcess done", showProc p] return (toConcurrentProcessHandle r) + +debug :: [String] -> IO () +debug = debugM "concurrent-output" . unwords +showProc :: P.CreateProcess -> String +showProc = go . P.cmdspec + where + go (P.ShellCommand s) = s + go (P.RawCommand c ps) = show (c, ps) + #ifndef mingw32_HOST_OS bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) bgProcess p = do (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe + debug ["bgProcess", showProc p] let p' = p { P.std_out = rediroutput (P.std_out p) toouth , P.std_err = rediroutput (P.std_err p) toerrh @@ -402,7 +416,7 @@ ( void $ mapConcurrently displaybuf ts , noop -- buffers already moved to global ) - worker2 <- async $ void $ globalbuf activitysig + worker2 <- async $ void $ globalbuf activitysig worker1 void $ async $ do void $ waitCatch worker1 void $ waitCatch worker2 @@ -419,7 +433,7 @@ case change of Right BufSig -> displaybuf v Left AtEnd -> return () - globalbuf activitysig = do + globalbuf activitysig worker1 = do ok <- atomically $ do -- signal we're going to handle it -- (returns false if the displaybuf already did) @@ -436,6 +450,9 @@ atomically $ forM_ bs $ \(outh, b) -> bufferOutputSTM' outh b + -- worker1 might be blocked waiting for the output + -- lock, and we've already done its job, so cancel it + cancel worker1 -- Adds a value to the OutputBuffer. When adding Output to a Handle, -- it's cheaper to combine it with any already buffered Output to that diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -18,6 +18,7 @@ readProcessEnv, writeReadProcessEnv, forceSuccessProcess, + forceSuccessProcess', checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, @@ -129,11 +130,12 @@ -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () -forceSuccessProcess p pid = do - code <- waitForProcess pid - case code of - ExitSuccess -> return () - ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n +forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p + +forceSuccessProcess' :: CreateProcess -> ExitCode -> IO () +forceSuccessProcess' _ ExitSuccess = return () +forceSuccessProcess' p (ExitFailure n) = fail $ + showCmd p ++ " exited " ++ show n -- | Waits for a ProcessHandle and returns True if it exited successfully. -- Note that using this with createProcessChecked will throw away diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Process/NonConcurrent.hs @@ -0,0 +1,35 @@ +{- Running processes in the foreground, not via the concurrent-output + - layer. + - + - Avoid using this in propellor properties! + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Process.NonConcurrent where + +import System.Process +import System.Exit +import System.IO +import Utility.SafeCommand +import Control.Applicative +import Prelude + +boolSystemNonConcurrent :: String -> [CommandParam] -> IO Bool +boolSystemNonConcurrent cmd params = do + (Nothing, Nothing, Nothing, p) <- createProcessNonConcurrent $ + proc cmd (toCommand params) + dispatch <$> waitForProcessNonConcurrent p + where + dispatch ExitSuccess = True + dispatch _ = False + +createProcessNonConcurrent :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcessNonConcurrent = createProcess + +waitForProcessNonConcurrent :: ProcessHandle -> IO ExitCode +waitForProcessNonConcurrent = waitForProcess