diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,44 @@ +propellor (2.1.0) unstable; urgency=medium + + * Additional tor properties, including support for making relays, + and naming bridges, relays, etc. + * New Cron.Times data type, which allows Cron.job to install + daily/monthly/weekly jobs that anacron can run. (API change) + * Fix Git.daemonRunning to restart inetd after enabling the git server. + * Ssh.authorizedKey: Make the authorized_keys file and .ssh directory + be owned by the user, not root. + * Ssh.knownHost: Make the .ssh directory be owned by the user, not root. + + -- Joey Hess Thu, 12 Feb 2015 12:36:26 -0400 + +propellor (2.0.0) unstable; urgency=medium + + * Property has been converted to a GADT, and will be Property NoInfo + or Property HasInfo. + This was done to make sure that ensureProperty is only used on + properties that do not have Info. + Transition guide: + - Change all "Property" to "Property NoInfo" or "Property WithInfo" + (The compiler can tell you if you got it wrong!) + - To construct a RevertableProperty, it is useful to use the new + () operator + - Constructing a list of properties can be problimatic, since + Property NoInto and Property WithInfo are different types and cannot + appear in the same list. To deal with this, "props" has been added, + and can built up a list of properties of different types, + using the same (&) and (!) operators that are used to build + up a host's properties. + * Add descriptions of how to set missing fields to --list-fields output. + * Properties now form a tree, instead of the flat list used before. + This includes the properties used inside a container. + * Fix info propagation from fallback combinator's second Property. + * Added systemd configuration properties. + * Added journald configuration properties. + * Added more network interface configuration properties. + * Implemented OS.preserveNetwork. + + -- Joey Hess Sun, 25 Jan 2015 15:23:08 -0400 + propellor (1.3.2) unstable; urgency=medium * SSHFP records are also generated for CNAMES of hosts. diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -19,14 +19,13 @@ import qualified Propellor.Property.OpenId as OpenId import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Git as Git -import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix 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.OS as OS -import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode import qualified Propellor.Property.SiteSpecific.GitHome as GitHome @@ -46,7 +45,7 @@ , kite , diatom , elephant - , testvm + , beaver ] ++ monsters testvm :: Host @@ -86,7 +85,7 @@ & Ssh.randomHostKeys & Apt.unattendedUpgrades & Network.ipv6to4 - & Tor.isBridge + & Tor.named "kite1" Tor.isRelay' & Postfix.satellite & Docker.configured @@ -118,8 +117,8 @@ & Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h") & Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h") & Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage) - & Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h") - & Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h") + & Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage (Cron.Times "1 3 * * *") "5h") + & Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage (Cron.Times "1 1 * * *") "3h") & Docker.garbageCollected `period` Daily & Apt.buildDep ["git-annex"] `period` Daily @@ -128,7 +127,7 @@ -- with propellor. kite :: Host kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" - [ "Welcome to the new kitenet.net server!" ] + [ "Welcome to kite!" ] & ipv4 "66.228.36.95" & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" & alias "kitenet.net" @@ -140,15 +139,18 @@ , (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: & Apt.serviceInstalledRunning "fail2ban" - & Obnam.backupEncrypted "/" "33 1 * * *" + & Obnam.backupEncrypted "/" (Cron.Times "33 1 * * *") [ "--repository=sftp://joey@eubackup.kitenet.net/~/lib/backup/kite.obnam" , "--client-name=kitenet.net" , "--exclude=/var/cache" @@ -169,13 +171,19 @@ & alias "mail.kitenet.net" & JoeySites.kiteMailServer - & alias "ns4.kitenet.net" - & myDnsSecondary - & alias "ns4.branchable.com" - & branchableSecondary - + & JoeySites.kitenetHttps & JoeySites.legacyWebSites + & File.ownerGroup "/srv/web" "joey" "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` @@ -199,73 +207,32 @@ & Docker.configured & Docker.garbageCollected `period` Daily - & Docker.docked oldusenetShellBox - -diatom :: Host -diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64" - [ "Important stuff that needs not too much memory or CPU." ] - & ipv4 "107.170.31.195" - & Ssh.hostKeys hostContext - [ (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=") - ] - - & DigitalOcean.distroKernel - & Apt.unattendedUpgrades - & Apt.serviceInstalledRunning "ntp" - & Postfix.satellite - - -- Diatom has 500 mb of memory, so tune for that. - & JoeySites.obnamLowMem - & Apt.serviceInstalledRunning "swapspace" - - & Apt.serviceInstalledRunning "apache2" - & JoeySites.kitenetHttps - & Apache.multiSSL - & File.ownerGroup "/srv/web" "joey" "joey" - & Apt.installed ["analog"] - - & alias "git.kitenet.net" - & alias "git.joeyh.name" - & JoeySites.gitServer hosts - - & JoeySites.annexWebSite "/srv/git/downloads.git" - "downloads.kitenet.net" - "840760dc-08f0-11e2-8c61-576b7e66acfd" - [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")] - `requires` Ssh.keyImported SshRsa "joey" (Context "downloads.kitenet.net") - `requires` Ssh.knownHost hosts "eubackup.kitenet.net" "joey" - & JoeySites.gitAnnexDistributor - - & JoeySites.annexWebSite "/srv/git/joey/tmp.git" - "tmp.kitenet.net" - "26fd6e38-1226-11e2-a75f-ff007033bdba" - [] - & JoeySites.twitRss - & JoeySites.pumpRss + ! Docker.docked oldusenetShellBox - & JoeySites.annexWebSite "/srv/git/user-liberation.git" - "user-liberation.joeyh.name" - "da89f112-808b-420a-b468-d990ae2e5b52" - [] - & alias "nntp.olduse.net" - & alias "resources.olduse.net" & JoeySites.oldUseNetServer hosts - & alias "ns2.kitenet.net" - & myDnsPrimary False "kitenet.net" [] + & 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 "ns3.branchable.com" + & alias "ns4.branchable.com" & branchableSecondary - & Dns.secondaryFor ["animx"] hosts "animx.eu.org" +diatom :: Host +diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64" + [ "dying" ] + & ipv4 "107.170.31.195" + & Ssh.hostKeys hostContext + [ (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=") + ] + & alias "ns2.kitenet.net" + elephant :: Host elephant = standardSystem "elephant.kitenet.net" Unstable "amd64" [ "Storage, big data, and backups, omnomnom!" @@ -292,7 +259,6 @@ & JoeySites.obnamRepos ["wren", "pell", "kite"] & JoeySites.githubBackup & JoeySites.rsyncNetBackup hosts - & JoeySites.backupsBackedupTo hosts "usbackup.kitenet.net" "lib/backup/eubackup" & alias "podcatcher.kitenet.net" & JoeySites.podcatcher @@ -326,14 +292,27 @@ -- 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.pubKey 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 "root" "/" + "rsync -a -x / /home/joey/lib/backup/beaver.kitenet.net/" - --' __|II| ,. - ---- __|II|II|__ ( \_,/\ - ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'- - ----------------------- | [Docker] / ---------------------- - ----------------------- : / ----------------------- - ------------------------ \____, o ,' ------------------------ - ------------------------- '--,___________,' ------------------------- + + --' __|II| ,. + ---- __|II|II|__ ( \_,/\ +--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'- +-------------------------- | [Docker] / -------------------------- +-------------------------- : / --------------------------- +--------------------------- \____, o ,' ---------------------------- +---------------------------- '--,___________,' ----------------------------- + -- Simple web server, publishing the outside host's /var/www webserver :: Docker.Container webserver = standardStableContainer "webserver" @@ -408,7 +387,7 @@ & Sudo.enabledFor "joey" & GitHome.installedFor "joey" & Apt.installed ["vim", "screen", "less"] - & Cron.runPropellor "30 * * * *" + & Cron.runPropellor (Cron.Times "30 * * * *") -- I use postfix, or no MTA. & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] `onChange` Apt.autoRemove @@ -434,45 +413,31 @@ dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch dockerImage _ = "debian-stable-official" -- does not currently exist! -myDnsSecondary :: Property -myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp - [ Dns.secondary hosts "kitenet.net" - , Dns.secondary hosts "joeyh.name" - , Dns.secondary hosts "ikiwiki.info" - , Dns.secondary hosts "olduse.net" - ] +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 branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" --- Currently using diatom (ns2) as primary with secondaries --- elephant (ns3), kite (ns4) and gandi. +-- Currently using kite (ns4) as primary with secondaries +-- elephant (ns3) and gandi. -- kite handles all mail. myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain - (Dns.mkSOA "ns2.kitenet.net" 100) $ - [ (RootDomain, NS $ AbsDomain "ns2.kitenet.net") + (Dns.mkSOA "ns4.kitenet.net" 100) $ + [ (RootDomain, NS $ AbsDomain "ns4.kitenet.net") , (RootDomain, NS $ AbsDomain "ns3.kitenet.net") - , (RootDomain, NS $ AbsDomain "ns4.kitenet.net") , (RootDomain, NS $ AbsDomain "ns6.gandi.net") , (RootDomain, MX 0 $ AbsDomain "kitenet.net") - -- SPF only allows IP address of kitenet.net to send mail. - , (RootDomain, TXT "v=spf1 a:kitenet.net -all") + , (RootDomain, TXT "v=spf1 a a:kitenet.net ~all") , JoeySites.domainKey ] ++ extras - -- o - -- ___ o o - {-----\ / o \ ___o o - { \ __ \ / _ (X___>-- __o - _____________________{ ______\___ \__/ | \__/ \____ |X__> - < \___//|\\___/\ \____________ _ - \ ___/ | \___ # # \ (-) - \ O O O # | \ # >=) - \______________________________# # / #__________________/ (-} - - monsters :: [Host] -- Systems I don't manage with propellor, monsters = -- but do want to track their public keys etc. [ host "usw-s002.rsync.net" @@ -484,13 +449,8 @@ , host "turtle.kitenet.net" & ipv4 "67.223.19.96" & ipv6 "2001:4978:f:2d9::2" - & alias "backup.kitenet.net" - & alias "usbackup.kitenet.net" - & Ssh.pubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAokMXQiX/NZjA1UbhMdgAscnS5dsmy+Q7bWrQ6tsTZ/o+6N/T5cbjoBHOdpypXJI3y/PiJTDJaQtXIhLa8gFg/EvxMnMz/KG9skADW1361JmfCc4BxicQIO2IOOe6eilPr+YsnOwiHwL0vpUnuty39cppuMWVD25GzxXlS6KQsLCvXLzxLLuNnGC43UAM0q4UwQxDtAZEK1dH2o3HMWhgMP2qEQupc24dbhpO3ecxh2C9678a3oGDuDuNf7mLp3s7ptj5qF3onitpJ82U5o7VajaHoygMaSRFeWxP2c13eM57j3bLdLwxVXFhePcKXARu1iuFTLS5uUf3hN6MkQcOGw==" , host "mouse.kitenet.net" & ipv6 "2001:4830:1600:492::2" - , host "beaver.kitenet.net" - & ipv6 "2001:4830:1600:195::2" , host "branchable.com" & ipv4 "66.228.46.55" & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5" @@ -508,3 +468,17 @@ & 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/config-simple.hs b/config-simple.hs --- a/config-simple.hs +++ b/config-simple.hs @@ -33,7 +33,7 @@ & File.dirExists "/var/www" & Docker.docked webserverContainer & Docker.garbageCollected `period` Daily - & Cron.runPropellor "30 * * * *" + & Cron.runPropellor (Cron.Times "30 * * * *") -- add more hosts here... --, host "foo.example.com" = ... diff --git a/config.hs b/config.hs --- a/config.hs +++ b/config.hs @@ -33,7 +33,7 @@ & File.dirExists "/var/www" & Docker.docked webserverContainer & Docker.garbageCollected `period` Daily - & Cron.runPropellor "30 * * * *" + & Cron.runPropellor (Cron.Times "30 * * * *") -- add more hosts here... --, host "foo.example.com" = ... diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,44 @@ +propellor (2.1.0) unstable; urgency=medium + + * Additional tor properties, including support for making relays, + and naming bridges, relays, etc. + * New Cron.Times data type, which allows Cron.job to install + daily/monthly/weekly jobs that anacron can run. (API change) + * Fix Git.daemonRunning to restart inetd after enabling the git server. + * Ssh.authorizedKey: Make the authorized_keys file and .ssh directory + be owned by the user, not root. + * Ssh.knownHost: Make the .ssh directory be owned by the user, not root. + + -- Joey Hess Thu, 12 Feb 2015 12:36:26 -0400 + +propellor (2.0.0) unstable; urgency=medium + + * Property has been converted to a GADT, and will be Property NoInfo + or Property HasInfo. + This was done to make sure that ensureProperty is only used on + properties that do not have Info. + Transition guide: + - Change all "Property" to "Property NoInfo" or "Property WithInfo" + (The compiler can tell you if you got it wrong!) + - To construct a RevertableProperty, it is useful to use the new + () operator + - Constructing a list of properties can be problimatic, since + Property NoInto and Property WithInfo are different types and cannot + appear in the same list. To deal with this, "props" has been added, + and can built up a list of properties of different types, + using the same (&) and (!) operators that are used to build + up a host's properties. + * Add descriptions of how to set missing fields to --list-fields output. + * Properties now form a tree, instead of the flat list used before. + This includes the properties used inside a container. + * Fix info propagation from fallback combinator's second Property. + * Added systemd configuration properties. + * Added journald configuration properties. + * Added more network interface configuration properties. + * Implemented OS.preserveNetwork. + + -- Joey Hess Sun, 25 Jan 2015 15:23:08 -0400 + propellor (1.3.2) unstable; urgency=medium * SSHFP records are also generated for CNAMES of hosts. diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -18,7 +18,7 @@ libghc-monadcatchio-transformers-dev, Maintainer: Gergely Nagy Standards-Version: 3.9.6 -Vcs-Git: git://git.kitenet.net/propellor +Vcs-Git: git://git.joeyh.name/propellor Homepage: http://propellor.branchable.com/ Package: propellor diff --git a/debian/copyright b/debian/copyright --- a/debian/copyright +++ b/debian/copyright @@ -2,7 +2,7 @@ Source: native package Files: * -Copyright: © 2010-2014 Joey Hess and contributors +Copyright: © 2010-2015 Joey Hess and contributors License: BSD-2-clause License: BSD-2-clause diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 1.3.2 +Version: 2.1.0 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess @@ -85,6 +85,7 @@ Propellor.Property.Gpg Propellor.Property.Group Propellor.Property.Grub + Propellor.Property.Journald Propellor.Property.Mount Propellor.Property.Network Propellor.Property.Nginx @@ -94,6 +95,7 @@ Propellor.Property.Postfix Propellor.Property.Prosody Propellor.Property.Reboot + Propellor.Property.List Propellor.Property.Scheduled Propellor.Property.Service Propellor.Property.Ssh @@ -108,7 +110,7 @@ Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.GitAnnexBuilder - Propellor.Host + Propellor.PropAccum Propellor.CmdLine Propellor.Info Propellor.Message @@ -122,6 +124,9 @@ Propellor.Types.Empty Propellor.Types.OS Propellor.Types.PrivData + Propellor.Types.Val + Propellor.Types.Result + Propellor.Types.CmdLine Other-Modules: Propellor.Git Propellor.Gpg @@ -133,11 +138,13 @@ Propellor.Property.Chroot.Util Utility.Applicative Utility.Data + Utility.DataUnits Utility.Directory Utility.Env Utility.Exception Utility.FileMode Utility.FileSystemEncoding + Utility.HumanNumber Utility.LinuxMkLibs Utility.Misc Utility.Monad diff --git a/src/Propellor.hs b/src/Propellor.hs --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -27,13 +27,14 @@ -- -- See config.hs for a more complete example, and clone Propellor's -- git repository for a deployable system using Propellor: --- git clone +-- git clone module Propellor ( module Propellor.Types , module Propellor.Property + , module Propellor.Property.List , module Propellor.Property.Cmd - , module Propellor.Host + , module Propellor.PropAccum , module Propellor.Info , module Propellor.PrivData , module Propellor.Types.PrivData @@ -48,13 +49,14 @@ import Propellor.Types import Propellor.Property import Propellor.Engine +import Propellor.Property.List import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Types.PrivData import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Host +import Propellor.PropAccum import Utility.PartialPrelude as X import Utility.Process as X diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -13,6 +13,7 @@ import Propellor.Gpg import Propellor.Git import Propellor.Spin +import Propellor.Types.CmdLine import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE GADTs #-} module Propellor.Engine ( mainProperties, @@ -35,7 +36,7 @@ mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ - ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty] + ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] h <- mkMessageHandle whenConsole h $ setTitle "propellor: done" @@ -43,6 +44,8 @@ case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess + where + ps = map ignoreInfo $ hostProperties host -- | Runs a Propellor action with the specified host. -- @@ -62,11 +65,13 @@ -- | For when code running in the Propellor monad needs to ensure a -- Property. -ensureProperty :: Property -> Propellor Result +-- +-- This can only be used on a Property that has NoInfo. +ensureProperty :: Property NoInfo -> Propellor Result ensureProperty = catchPropellor . propertySatisfy -- | Ensures a list of Properties, with a display of each as it runs. -ensureProperties :: [Property] -> Propellor Result +ensureProperties :: [Property NoInfo] -> Propellor Result ensureProperties ps = ensure ps NoChange where ensure [] rs = return rs @@ -77,7 +82,7 @@ -- | Lifts an action into a different host. -- --- For example, `fromHost hosts "otherhost" getPubKey` +-- > fromHost hosts "otherhost" getPubKey fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) fromHost l hn getter = case findHost l hn of Nothing -> return Nothing diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs deleted file mode 100644 --- a/src/Propellor/Host.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Propellor.Host where - -import Data.Monoid -import qualified Data.Set as S - -import Propellor.Types -import Propellor.Info -import Propellor.Property -import Propellor.PrivData - --- | Starts accumulating the properties of a Host. --- --- > host "example.com" --- > & someproperty --- > ! oldproperty --- > & otherproperty -host :: HostName -> Host -host hn = Host hn [] mempty - --- | Something that can accumulate properties. -class Hostlike h where - -- | Adds a property. - -- - -- Can add Properties and RevertableProperties - (&) :: IsProp p => h -> p -> h - - -- | Like (&), but adds the property as the - -- first property of the host. Normally, property - -- order should not matter, but this is useful - -- when it does. - (&^) :: IsProp p => h -> p -> h - - getHost :: h -> Host - -instance Hostlike Host where - (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) - (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) - getHost h = h - --- | Adds a property in reverted form. -(!) :: Hostlike h => h -> RevertableProperty -> h -h ! p = h & revert p - -infixl 1 &^ -infixl 1 & -infixl 1 ! - --- | When eg, docking a container, some of the Info about the container --- should propigate out to the Host it's on. This includes DNS info, --- so that eg, aliases of the container are reflected in the dns for the --- host where it runs. --- --- This adjusts the Property that docks a container, to include such info --- from the container. -propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property -propigateInfo hl p f = combineProperties (propertyDesc p) $ - p' : dnsprops ++ privprops - where - p' = p { propertyInfo = f (propertyInfo p) } - i = hostInfo (getHost hl) - dnsprops = map addDNS (S.toList $ _dns i) - privprops = map addPrivDataField (S.toList $ _privDataFields i) diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -3,6 +3,7 @@ module Propellor.Info where import Propellor.Types +import Propellor.Types.Val import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -11,13 +12,13 @@ import Data.Monoid import Control.Applicative -pureInfoProperty :: Desc -> Info -> Property -pureInfoProperty desc = Property ("has " ++ desc) (return NoChange) +pureInfoProperty :: Desc -> Info -> Property HasInfo +pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty askInfo :: (Info -> Val a) -> Propellor (Maybe a) askInfo f = asks (fromVal . f . hostInfo) -os :: System -> Property +os :: System -> Property HasInfo os system = pureInfoProperty ("Operating " ++ show system) $ mempty { _os = Val system } @@ -33,11 +34,11 @@ -- When propellor --spin is used to deploy a host, it checks -- if the host's IP Property matches the DNS. If the DNS is missing or -- out of date, the host will instead be contacted directly by IP address. -ipv4 :: String -> Property +ipv4 :: String -> Property HasInfo ipv4 = addDNS . Address . IPv4 -- | Indidate that a host has an AAAA record in the DNS. -ipv6 :: String -> Property +ipv6 :: String -> Property HasInfo ipv6 = addDNS . Address . IPv6 -- | Indicates another name for the host in the DNS. @@ -46,7 +47,7 @@ -- to use their address, rather than using a CNAME. This avoids various -- problems with CNAMEs, and also means that when multiple hosts have the -- same alias, a DNS round-robin is automatically set up. -alias :: Domain -> Property +alias :: Domain -> Property HasInfo alias d = pureInfoProperty ("alias " ++ d) $ mempty { _aliases = S.singleton d -- A CNAME is added here, but the DNS setup code converts it to an @@ -54,7 +55,7 @@ , _dns = S.singleton $ CNAME $ AbsDomain d } -addDNS :: Record -> Property +addDNS :: Record -> Property HasInfo addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r } where rdesc (CNAME d) = unwords ["alias", ddesc d] diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -1,6 +1,19 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} -module Propellor.PrivData where +module Propellor.PrivData ( + withPrivData, + withSomePrivData, + addPrivData, + setPrivData, + dumpPrivData, + editPrivData, + filterPrivData, + listPrivDataFields, + makePrivDataDir, + decryptPrivData, + PrivMap, +) where import Control.Applicative import System.IO @@ -48,29 +61,29 @@ -- being used, which is necessary to ensure that the privdata is sent to -- the remote host by propellor. withPrivData - :: (IsContext c, IsPrivDataSource s) + :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) => s -> c - -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) - -> Property + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i) + -> Property HasInfo withPrivData s = withPrivData' snd [s] -- Like withPrivData, but here any one of a list of PrivDataFields can be used. withSomePrivData - :: (IsContext c, IsPrivDataSource s) + :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) => [s] -> c - -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property) - -> Property + -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i) + -> Property HasInfo withSomePrivData = withPrivData' id withPrivData' - :: (IsContext c, IsPrivDataSource s) + :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) => ((PrivDataField, PrivData) -> v) -> [s] -> c - -> (((v -> Propellor Result) -> Propellor Result) -> Property) - -> Property + -> (((v -> Propellor Result) -> Propellor Result) -> Property i) + -> Property HasInfo withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> maybe missing (a . feed) =<< getM get fieldlist where @@ -82,21 +95,29 @@ Context cname <- mkHostContext hc <$> asks hostName warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" liftIO $ putStrLn $ "Fix this by running:" - liftIO $ forM_ srclist $ \src -> do - putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "' \\" - maybe noop (\d -> putStrLn $ " " ++ d) (describePrivDataSource src) - putStrLn "" + liftIO $ showSet $ + map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist return FailedChange - addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = fieldset } } + addinfo p = infoProperty + (propertyDesc p) + (propertySatisfy p) + (propertyInfo p <> mempty { _privData = privset }) + (propertyChildren p) + privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist fieldnames = map show fieldlist - fieldset = S.fromList $ zip fieldlist (repeat hc) fieldlist = map privDataField srclist hc = asHostContext c -addPrivDataField :: (PrivDataField, HostContext) -> Property -addPrivDataField v = pureInfoProperty (show v) $ - mempty { _privDataFields = S.singleton v } +showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO () +showSet l = forM_ l $ \(f, Context c, md) -> do + putStrLn $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" + maybe noop (\d -> putStrLn $ " " ++ d) md + putStrLn "" +addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo +addPrivData v = pureInfoProperty (show v) $ + mempty { _privData = S.singleton v } + {- Gets the requested field's value, in the specified context if it's - available, from the host's local privdata cache. -} getLocalPrivData :: PrivDataField -> Context -> IO (Maybe PrivData) @@ -107,12 +128,12 @@ type PrivMap = M.Map (PrivDataField, Context) PrivData -{- Get only the set of PrivData that the Host's Info says it uses. -} +-- | Get only the set of PrivData that the Host's Info says it uses. filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used) where - used = S.map (\(f, c) -> (f, mkHostContext c (hostName host))) $ - _privDataFields $ hostInfo host + used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $ + _privData $ hostInfo host getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData getPrivData field context = M.lookup (field, context) @@ -142,10 +163,17 @@ listPrivDataFields :: [Host] -> IO () listPrivDataFields hosts = do m <- decryptPrivData - showtable "Currently set data:" $ - map mkrow (M.keys m) - showtable "Data that would be used if set:" $ - map mkrow (M.keys $ M.difference wantedmap m) + + section "Currently set data:" + showtable $ map mkrow (M.keys m) + let missing = M.keys $ M.difference wantedmap m + + unless (null missing) $ do + section "Missing data that would be used if set:" + showtable $ map mkrow missing + + section "How to set missing data:" + showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing where header = ["Field", "Context", "Used by"] mkrow k@(field, (Context context)) = @@ -153,12 +181,13 @@ , shellEscape context , intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby ] - mkhostmap host = M.fromList $ map (\(f, c) -> ((f, mkHostContext c (hostName host)), [hostName host])) $ - S.toList $ _privDataFields $ hostInfo host - usedby = M.unionsWith (++) $ map mkhostmap hosts + mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $ + S.toList $ _privData $ hostInfo host + usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts wantedmap = M.fromList $ zip (M.keys usedby) (repeat "") - showtable desc rows = do - putStrLn $ "\n" ++ desc + descmap = M.unions $ map (\h -> mkhostmap h id) hosts + section desc = putStrLn $ "\n" ++ desc + showtable rows = do putStr $ unlines $ formatTable $ tableWithHeader header rows setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/PropAccum.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.PropAccum + ( host + , props + , PropAccum(..) + , (!) + , PropList + , propigateContainer + ) where + +import Data.Monoid + +import Propellor.Types +import Propellor.Property + +-- | Starts accumulating the properties of a Host. +-- +-- > host "example.com" +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Host +host hn = Host hn [] mempty + +-- | Starts accumulating a list of properties. +-- +-- > propertyList "foo" $ props +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +props :: PropList +props = PropList [] + +-- | Something that can accumulate properties. +class PropAccum h where + -- | Adds a property. + -- + -- Can add Properties and RevertableProperties + (&) :: IsProp p => h -> p -> h + + -- | Like (&), but adds the property at the front of the list. + (&^) :: IsProp p => h -> p -> h + + getProperties :: h -> [Property HasInfo] + +instance PropAccum Host where + (Host hn ps is) & p = Host hn (ps ++ [toProp p]) + (is <> getInfoRecursive p) + (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) + (getInfoRecursive p <> is) + getProperties = hostProperties + +data PropList = PropList [Property HasInfo] + +instance PropAccum PropList where + PropList l & p = PropList (toProp p : l) + PropList l &^ p = PropList (l ++ [toProp p]) + getProperties (PropList l) = reverse l + +-- | Adds a property in reverted form. +(!) :: PropAccum h => h -> RevertableProperty -> h +h ! p = h & revert p + +infixl 1 &^ +infixl 1 & +infixl 1 ! + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. +-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propigated out to the Property. +-- +-- DNS Info is propigated, so that eg, aliases of a PropAccum +-- are reflected in the dns for the host where it runs. +-- +-- PrivData Info is propigated, so that properties used inside a +-- PropAccum will have the necessary PrivData available. +propigateContainer + :: (PropAccum container) + => container + -> Property HasInfo + -> Property HasInfo +propigateContainer c prop = infoProperty + (propertyDesc prop) + (propertySatisfy prop) + (propertyInfo prop) + (propertyChildren prop ++ hostprops) + where + hostprops = map go $ getProperties c + go p = + let i = propertyInfo p + i' = mempty + { _dns = _dns i + , _privData = _privData i + } + cs = map go (propertyChildren p) + in infoProperty (propertyDesc p) (propertySatisfy p) i' cs diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} module Propellor.Property where @@ -11,47 +12,21 @@ import Propellor.Types import Propellor.Info -import Propellor.Engine import Utility.Monad --- Constructs a Property. -property :: Desc -> Propellor Result -> Property -property d s = Property d s mempty - --- | Combines a list of properties, resulting in a single property --- that when run will run each property in the list in turn, --- and print out the description of each as it's run. Does not stop --- on failure; does propigate overall success/failure. -propertyList :: Desc -> [Property] -> Property -propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps) - --- | Combines a list of properties, resulting in one property that --- ensures each in turn. Stops if a property fails. -combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps) - where - go [] rs = return rs - go (l:ls) rs = do - r <- ensureProperty l - case r of - FailedChange -> return FailedChange - _ -> go ls (r <> rs) - --- | Combines together two properties, resulting in one property --- that ensures the first, and if the first succeeds, ensures the second. --- The property uses the description of the first property. -before :: Property -> Property -> Property -p1 `before` p2 = p2 `requires` p1 - `describe` (propertyDesc p1) +-- | Constructs a Property, from a description and an action to run to +-- ensure the Property is met. +property :: Desc -> Propellor Result -> Property NoInfo +property d s = simpleProperty d s mempty -- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- file to indicate whether it has run before. -- Use with caution. -flagFile :: Property -> FilePath -> Property +flagFile :: Property i -> FilePath -> Property i flagFile p = flagFile' p . return -flagFile' :: Property -> IO FilePath -> Property -flagFile' p getflagfile = adjustProperty p $ \satisfy -> do +flagFile' :: Property i -> IO FilePath -> Property i +flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do flagfile <- liftIO getflagfile go satisfy flagfile =<< liftIO (doesFileExist flagfile) where @@ -64,37 +39,40 @@ writeFile flagfile "" return r ---- | Whenever a change has to be made for a Property, causes a hook +-- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. -onChange :: Property -> Property -> Property -p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook) - where - satisfy = do - r <- ensureProperty p - case r of - MadeChange -> do - r' <- ensureProperty hook - return $ r <> r' - _ -> return r +onChange + :: (Combines (Property x) (Property y)) + => Property x + -> Property y + -> CombinedType (Property x) (Property y) +onChange = combineWith $ \p hook -> do + r <- p + case r of + MadeChange -> do + r' <- hook + return $ r <> r' + _ -> return r -(==>) :: Desc -> Property -> Property +-- | Alias for @flip describe@ +(==>) :: IsProp (Property i) => Desc -> Property i -> Property i (==>) = flip describe infixl 1 ==> -- | Makes a Property only need to do anything when a test succeeds. -check :: IO Bool -> Property -> Property -check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) +check :: IO Bool -> Property i -> Property i +check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c) ( satisfy , return NoChange ) -- | Tries the first property, but if it fails to work, instead uses -- the second. -fallback :: Property -> Property -> Property -fallback p1 p2 = adjustProperty p1 $ \satisfy -> do - r <- satisfy +fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2) +fallback = combineWith $ \a1 a2 -> do + r <- a1 if r == FailedChange - then propertySatisfy p2 + then a2 else return r -- | Marks a Property as trivial. It can only return FailedChange or @@ -103,43 +81,32 @@ -- Useful when it's just as expensive to check if a change needs -- to be made as it is to just idempotently assure the property is -- satisfied. For example, chmodding a file. -trivial :: Property -> Property -trivial p = adjustProperty p $ \satisfy -> do +trivial :: Property i -> Property i +trivial p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy if r == MadeChange then return NoChange else return r -doNothing :: Property -doNothing = property "noop property" noChange - -- | Makes a property that is satisfied differently depending on the host's -- operating system. -- -- Note that the operating system may not be declared for some hosts. -withOS :: Desc -> (Maybe System -> Propellor Result) -> Property +withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo withOS desc a = property desc $ a =<< getOS -- | Undoes the effect of a property. revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- | Changes the action that is performed to satisfy a property. -adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property -adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } - --- | Combines the Info of two properties. -combineInfo :: (IsProp p, IsProp q) => p -> q -> Info -combineInfo p q = getInfo p <> getInfo q - -combineInfos :: IsProp p => [p] -> Info -combineInfos = mconcat . map getInfo - makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange + +doNothing :: Property NoInfo +doNothing = property "noop property" noChange -- | Registers an action that should be run at the very end, endAction :: Desc -> (Result -> Propellor Result) -> Propellor () 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 @@ -9,7 +9,7 @@ type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty -siteEnabled hn cf = RevertableProperty enable disable +siteEnabled hn cf = enable disable where enable = combineProperties ("apache site enabled " ++ hn) [ siteAvailable hn cf @@ -28,14 +28,14 @@ `onChange` reloaded isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn] -siteAvailable :: HostName -> ConfigFile -> Property +siteAvailable :: HostName -> ConfigFile -> Property NoInfo siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ map (`File.hasContent` (comment:cf)) (siteCfg hn) where comment = "# deployed with propellor, do not modify" modEnabled :: String -> RevertableProperty -modEnabled modname = RevertableProperty enable disable +modEnabled modname = enable disable where enable = check (not <$> isenabled) $ cmdProperty "a2enmod" ["--quiet", modname] @@ -59,24 +59,28 @@ , "/etc/apache2/sites-available/" ++ hn ++ ".conf" ] -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["apache2"] -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "apache2" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "apache2" -- | Configure apache to use SNI to differentiate between -- https hosts. -multiSSL :: Property -multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent` - [ "NameVirtualHost *:443" - , "SSLStrictSNIVHostCheck off" - ] - `describe` "apache SNI enabled" - `onChange` reloaded +-- +-- This was off by default in apache 2.2.22. Newver versions enable +-- it by default. This property uses the filename used by the old version. +multiSSL :: Property NoInfo +multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $ + "/etc/apache2/conf.d/ssl" `File.hasContent` + [ "NameVirtualHost *:443" + , "SSLStrictSNIVHostCheck off" + ] + `describe` "apache SNI enabled" + `onChange` reloaded -- | Config file fragment that can be inserted into a -- stanza to allow global read access to the directory. 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Apt where import Data.Maybe @@ -77,36 +79,36 @@ -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. -stdSourcesList :: Property +stdSourcesList :: Property NoInfo stdSourcesList = withOS ("standard sources.list") $ \o -> case o of (Just (System (Debian suite) _)) -> ensureProperty $ stdSourcesListFor suite _ -> error "os is not declared to be Debian" -stdSourcesListFor :: DebianSuite -> Property +stdSourcesListFor :: DebianSuite -> Property NoInfo stdSourcesListFor suite = stdSourcesList' suite [] -- | Adds additional sources.list generators. -- -- Note that if a Property needs to enable an apt source, it's better -- to do so via a separate file in -stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property +stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo stdSourcesList' suite more = setSourcesList (concatMap (\gen -> gen suite) generators) `describe` ("standard sources.list for " ++ show suite) where generators = [debCdn, kernelOrg, securityUpdates] ++ more -setSourcesList :: [Line] -> Property +setSourcesList :: [Line] -> Property NoInfo setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update -setSourcesListD :: [Line] -> FilePath -> Property +setSourcesListD :: [Line] -> FilePath -> Property NoInfo setSourcesListD ls basename = f `File.hasContent` ls `onChange` update where f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> Property +runApt :: [String] -> Property NoInfo runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv noninteractiveEnv :: [(String, String)] @@ -115,26 +117,26 @@ , ("APT_LISTCHANGES_FRONTEND", "none") ] -update :: Property +update :: Property NoInfo update = runApt ["update"] `describe` "apt update" -upgrade :: Property +upgrade :: Property NoInfo upgrade = runApt ["-y", "dist-upgrade"] `describe` "apt dist-upgrade" type Package = String -installed :: [Package] -> Property +installed :: [Package] -> Property NoInfo installed = installed' ["-y"] -installed' :: [String] -> [Package] -> Property +installed' :: [String] -> [Package] -> Property NoInfo installed' params ps = robustly $ check (isInstallable ps) go `describe` (unwords $ "apt installed":ps) where go = runApt $ params ++ ["install"] ++ ps -installedBackport :: [Package] -> Property +installedBackport :: [Package] -> Property NoInfo installedBackport ps = trivial $ withOS desc $ \o -> case o of Nothing -> error "cannot install backports; os not declared" (Just (System (Debian suite) _)) -> case backportSuite suite of @@ -147,16 +149,16 @@ notsupported o = error $ "backports not supported on " ++ show o -- | Minimal install of package, without recommends. -installedMin :: [Package] -> Property +installedMin :: [Package] -> Property NoInfo installedMin = installed' ["--no-install-recommends", "-y"] -removed :: [Package] -> Property +removed :: [Package] -> Property NoInfo removed ps = check (or <$> isInstalled' ps) go `describe` (unwords $ "apt removed":ps) where go = runApt $ ["-y", "remove"] ++ ps -buildDep :: [Package] -> Property +buildDep :: [Package] -> Property NoInfo buildDep ps = robustly go `describe` (unwords $ "apt build-dep":ps) where @@ -165,7 +167,7 @@ -- | Installs the build deps for the source package unpacked -- in the specifed directory, with a dummy package also -- installed so that autoRemove won't remove them. -buildDepIn :: FilePath -> Property +buildDepIn :: FilePath -> Property NoInfo buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] where go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] @@ -173,11 +175,13 @@ -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. -robustly :: Property -> Property -robustly p = adjustProperty p $ \satisfy -> do +robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i +robustly p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy if r == FailedChange - then ensureProperty $ p `requires` update + -- Safe to use ignoreInfo because we're re-running + -- the same property. + then ensureProperty $ ignoreInfo $ p `requires` update else return r isInstallable :: [Package] -> IO Bool @@ -203,13 +207,13 @@ environ <- addEntry "LANG" "C" <$> getEnvironment readProcessEnv "apt-cache" ("policy":ps) (Just environ) -autoRemove :: Property +autoRemove :: Property NoInfo autoRemove = runApt ["-y", "autoremove"] `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. unattendedUpgrades :: RevertableProperty -unattendedUpgrades = RevertableProperty enable disable +unattendedUpgrades = enable disable where enable = setup True `before` Service.running "cron" @@ -237,7 +241,7 @@ -- | Preseeds debconf values and reconfigures the package so it takes -- effect. -reConfigure :: Package -> [(String, String, String)] -> Property +reConfigure :: Package -> [(String, String, String)] -> Property NoInfo reConfigure package vals = reconfigure `requires` setselections `describe` ("reconfigure " ++ package) where @@ -253,7 +257,7 @@ -- -- Assumes that there is a 1:1 mapping between service names and apt -- package names. -serviceInstalledRunning :: Package -> Property +serviceInstalledRunning :: Package -> Property NoInfo serviceInstalledRunning svc = Service.running svc `requires` installed [svc] data AptKey = AptKey @@ -262,20 +266,27 @@ } trustsKey :: AptKey -> RevertableProperty -trustsKey k = RevertableProperty trust untrust +trustsKey k = trustsKey' k untrustKey k + +trustsKey' :: AptKey -> Property NoInfo +trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do + withHandle StdinHandle createProcessSuccess + (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do + hPutStr h (pubkey k) + hClose h + nukeFile $ f ++ "~" -- gpg dropping where desc = "apt trusts key " ++ keyname k - f = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" - untrust = File.notPresent f - trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do - withHandle StdinHandle createProcessSuccess - (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do - hPutStr h (pubkey k) - hClose h - nukeFile $ f ++ "~" -- gpg dropping + f = aptKeyFile k +untrustKey :: AptKey -> Property NoInfo +untrustKey = File.notPresent . aptKeyFile + +aptKeyFile :: AptKey -> FilePath +aptKeyFile k = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" + -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space. -cacheCleaned :: Property +cacheCleaned :: Property NoInfo cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"] `describe` "apt cache cleaned" 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 @@ -1,5 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Chroot ( Chroot(..), + BuilderConf(..), debootstrapped, provisioned, -- * Internal use @@ -10,6 +13,7 @@ ) where import Propellor +import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap @@ -28,10 +32,10 @@ = UsingDeboostrap Debootstrap.DebootstrapConfig deriving (Show) -instance Hostlike Chroot where +instance PropAccum Chroot where (Chroot l s c h) & p = Chroot l s c (h & p) (Chroot l s c h) &^ p = Chroot l s c (h &^ p) - getHost (Chroot _ _ _ h) = h + getProperties (Chroot _ _ _ h) = hostProperties h -- | Defines a Chroot at the given location, built with debootstrap. -- @@ -57,12 +61,13 @@ provisioned :: Chroot -> RevertableProperty provisioned c = provisioned' (propigateChrootInfo c) c False -provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty -provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty +provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty +provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = (propigator $ go "exists" setup) + (go "removed" teardown) where - go desc a = property (chrootDesc c desc) $ ensureProperties [a] + go desc a = propertyList (chrootDesc c desc) [a] setup = propellChroot c (inChrootProcess c) systemdonly `requires` toProp built @@ -75,15 +80,21 @@ teardown = toProp (revert built) -propigateChrootInfo :: Chroot -> Property -> Property -propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c) +propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo +propigateChrootInfo c p = propigateContainer c p' + where + p' = infoProperty + (propertyDesc p) + (propertySatisfy p) + (propertyInfo p <> chrootInfo c) + (propertyChildren p) chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ _ h) = mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property +propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" @@ -140,7 +151,8 @@ r <- runPropellor h $ ensureProperties $ if systemdonly then [Systemd.installed] - else hostProperties h + else map ignoreInfo $ + hostProperties h putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -19,12 +19,12 @@ -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success. -cmdProperty :: String -> [String] -> Property +cmdProperty :: String -> [String] -> Property NoInfo cmdProperty cmd params = cmdProperty' cmd params [] -- | A property that can be satisfied by running a command, -- with added environment. -cmdProperty' :: String -> [String] -> [(String, String)] -> Property +cmdProperty' :: String -> [String] -> [(String, String)] -> Property NoInfo cmdProperty' cmd params env = property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment toResult <$> boolSystemEnv cmd (map Param params) (Just env') @@ -32,14 +32,14 @@ desc = unwords $ cmd : params -- | A property that can be satisfied by running a series of shell commands. -scriptProperty :: [String] -> Property +scriptProperty :: [String] -> Property NoInfo scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script) -- | A property that can satisfied by running a series of shell commands, -- as user (cd'd to their home directory). -userScriptProperty :: UserName -> [String] -> Property +userScriptProperty :: UserName -> [String] -> Property NoInfo userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user] where shellcmd = intercalate " ; " ("set -e" : "cd" : script) 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 @@ -8,18 +8,26 @@ import Data.Char -type CronTimes = String +-- | When to run a cron job. +-- +-- The Daily, Monthly, and Weekly options allow the cron job to be run +-- by anacron, which is useful for non-servers. +data Times + = Times String -- ^ formatted as in crontab(5) + | Daily + | Weekly + | Monthly --- | Installs a cron job, run as a specified user, in a particular --- directory. Note that the Desc must be unique, as it is used for the --- cron.d/ filename. +-- | Installs a cron job, that will run as a specified user in a particular +-- directory. Note that the Desc must be unique, as it is used for the +-- cron job filename. -- -- Only one instance of the cron job is allowed to run at a time, no matter -- how long it runs. This is accomplished using flock locking of the cron -- job file. -- -- The cron job's output will only be emailed if it exits nonzero. -job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +job :: Desc -> Times -> UserName -> FilePath -> String -> Property NoInfo job desc times user cddir command = combineProperties ("cronned " ++ desc) [ cronjobfile `File.hasContent` [ "# Generated by propellor" @@ -27,8 +35,15 @@ , "SHELL=/bin/sh" , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" , "" - , times ++ "\t" ++ user ++ "\tchronic " ++ shellEscape scriptfile + , case times of + Times t -> t ++ "\t" ++ user ++ "\tchronic " ++ shellEscape scriptfile + _ -> case user of + "root" -> "chronic " ++ shellEscape scriptfile + _ -> "chronic su " ++ user ++ " -c " ++ shellEscape scriptfile ] + , case times of + Times _ -> doNothing + _ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes) -- Use a separate script because it makes the cron job name -- prettier in emails, and also allows running the job manually. , scriptfile `File.hasContent` @@ -44,7 +59,12 @@ `requires` Apt.installed ["util-linux", "moreutils"] where cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" - cronjobfile = "/etc/cron.d/" ++ name + cronjobfile = "/etc" cronjobdir name + cronjobdir = case times of + Times _ -> "cron.d" + Daily -> "cron.daily" + Weekly -> "cron.weekly" + Monthly -> "cron.monthly" scriptfile = "/usr/local/bin/" ++ name ++ "_cronjob" name = map sanitize desc sanitize c @@ -52,10 +72,10 @@ | otherwise = '_' -- | Installs a cron job, and runs it niced and ioniced. -niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +niceJob :: Desc -> Times -> UserName -> FilePath -> String -> Property NoInfo niceJob desc times user cddir command = job desc times user cddir ("nice ionice -c 3 sh -c " ++ shellEscape command) -- | Installs a cron job to run propellor. -runPropellor :: CronTimes -> Property +runPropellor :: Times -> Property NoInfo runPropellor times = niceJob "propellor" times "root" localdir "./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 @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Debootstrap ( Url, DebootstrapConfig(..), @@ -56,19 +58,18 @@ -- Note that reverting this property does not stop any processes -- currently running in the chroot. built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty -built = built' (toProp installed) - -built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty -built' installprop target system@(System _ arch) config = - RevertableProperty setup teardown +built target system config = built' (toProp installed) target system config teardown where - setup = check (unpopulated target <||> ispartial) setupprop - `requires` installprop - teardown = check (not <$> unpopulated target) teardownprop - unpopulated d = null <$> catchDefaultIO [] (dirContents d) + teardownprop = property ("removed debootstrapped " ++ target) $ + makeChange (removetarget target) +built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) +built' installprop target system@(System _ arch) config = + check (unpopulated target <||> ispartial) setupprop + `requires` installprop + where setupprop = property ("debootstrapped " ++ target) $ liftIO $ do createDirectoryIfMissing True target -- Don't allow non-root users to see inside the chroot, @@ -93,25 +94,26 @@ , return FailedChange ) - teardownprop = property ("removed debootstrapped " ++ target) $ - makeChange removetarget - - removetarget = do - submnts <- filter (\p -> simplifyPath p /= simplifyPath target) - . filter (dirContains target) - <$> mountPoints - forM_ submnts umountLazy - removeDirectoryRecursive target - -- A failed debootstrap run will leave a debootstrap directory; -- recover by deleting it and trying again. ispartial = ifM (doesDirectoryExist (target "debootstrap")) ( do - removetarget + removetarget target return True , return False ) + +unpopulated :: FilePath -> IO Bool +unpopulated d = null <$> catchDefaultIO [] (dirContents d) +removetarget :: FilePath -> IO () +removetarget target = do + submnts <- filter (\p -> simplifyPath p /= simplifyPath target) + . filter (dirContains target) + <$> mountPoints + forM_ submnts umountLazy + removeDirectoryRecursive target + extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s extractSuite (System (Ubuntu r) _) = Just r @@ -122,7 +124,7 @@ -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification. installed :: RevertableProperty -installed = RevertableProperty install remove +installed = install remove where install = withOS "debootstrap installed" $ \o -> ifM (liftIO $ isJust <$> programPath) @@ -142,18 +144,18 @@ aptinstall = Apt.installed ["debootstrap"] aptremove = Apt.removed ["debootstrap"] -sourceInstall :: Property +sourceInstall :: Property NoInfo sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall') `requires` perlInstalled `requires` arInstalled -perlInstalled :: Property +perlInstalled :: Property NoInfo perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ liftIO $ toResult . isJust <$> firstM id [ yumInstall "perl" ] -arInstalled :: Property +arInstalled :: Property NoInfo arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ liftIO $ toResult . isJust <$> firstM id [ yumInstall "binutils" @@ -197,7 +199,7 @@ return MadeChange _ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" -sourceRemove :: Property +sourceRemove :: Property NoInfo sourceRemove = property "debootstrap not installed from source" $ liftIO $ ifM (doesDirectoryExist sourceInstallDir) ( do diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -58,7 +58,7 @@ -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined. primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty -primary hosts domain soa rs = RevertableProperty setup cleanup +primary hosts domain soa rs = setup cleanup where setup = setupPrimary zonefile id hosts domain soa rs `onChange` Service.reloaded "bind9" @@ -67,7 +67,7 @@ zonefile = "/etc/bind/propellor/db." ++ domain -setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo setupPrimary zonefile mknamedconffile hosts domain soa rs = withwarnings baseprop `requires` servingZones @@ -77,8 +77,8 @@ indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap (partialzone, zonewarnings) = genZone indomain hostmap domain soa - baseprop = Property ("dns primary for " ++ domain) satisfy - (addNamedConf conf) + baseprop = infoProperty ("dns primary for " ++ domain) satisfy + (addNamedConf conf) [] satisfy = do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) let zone = partialzone @@ -87,7 +87,7 @@ ( makeChange $ writeZoneFile zone zonefile , noChange ) - withwarnings p = adjustProperty p $ \a -> do + withwarnings p = adjustPropertySatisfy p $ \a -> do mapM_ warningMessage $ zonewarnings ++ secondarywarnings a conf = NamedConf @@ -117,7 +117,7 @@ in z /= oldzone || oldserial < sSerial (zSOA zone) -cleanupPrimary :: FilePath -> Domain -> Property +cleanupPrimary :: FilePath -> Domain -> Property NoInfo cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ property ("removed dns primary for " ++ domain) (makeChange $ removeZoneFile zonefile) @@ -150,13 +150,14 @@ -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger. signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty -signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup +signedPrimary recurrance hosts domain soa rs = setup cleanup where - setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") - [ setupPrimary zonefile signedZoneFile hosts domain soa rs' - , toProp (zoneSigned domain zonefile) - , forceZoneSigned domain zonefile `period` recurrance - ] + setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") + (props + & setupPrimary zonefile signedZoneFile hosts domain soa rs' + & zoneSigned domain zonefile + & forceZoneSigned domain zonefile `period` recurrance + ) `onChange` Service.reloaded "bind9" cleanup = cleanupPrimary zonefile domain @@ -186,7 +187,7 @@ -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty -secondaryFor masters hosts domain = RevertableProperty setup cleanup +secondaryFor masters hosts domain = setup cleanup where setup = pureInfoProperty desc (addNamedConf conf) `requires` servingZones @@ -214,12 +215,12 @@ -- | Rewrites the whole named.conf.local file to serve the zones -- configured by `primary` and `secondary`, and ensures that bind9 is -- running. -servingZones :: Property +servingZones :: Property NoInfo servingZones = namedConfWritten `onChange` Service.reloaded "bind9" `requires` Apt.serviceInstalledRunning "bind9" -namedConfWritten :: Property +namedConfWritten :: Property NoInfo namedConfWritten = property "named.conf configured" $ do zs <- getNamedConf ensureProperty $ diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -8,7 +8,7 @@ -- signedPrimary uses this, so this property does not normally need to be -- used directly. keysInstalled :: Domain -> RevertableProperty -keysInstalled domain = RevertableProperty setup cleanup +keysInstalled domain = setup cleanup where setup = propertyList "DNSSEC keys installed" $ map installkey keys @@ -38,16 +38,14 @@ -- signedPrimary uses this, so this property does not normally need to be -- used directly. zoneSigned :: Domain -> FilePath -> RevertableProperty -zoneSigned domain zonefile = RevertableProperty setup cleanup +zoneSigned domain zonefile = setup cleanup where setup = check needupdate (forceZoneSigned domain zonefile) `requires` toProp (keysInstalled domain) - cleanup = combineProperties ("removed signed zone for " ++ domain) - [ File.notPresent (signedZoneFile zonefile) - , File.notPresent dssetfile - , toProp (revert (keysInstalled domain)) - ] + cleanup = File.notPresent (signedZoneFile zonefile) + `before` File.notPresent dssetfile + `before` toProp (revert (keysInstalled domain)) dssetfile = dir "-" ++ domain ++ "." dir = takeDirectory zonefile @@ -65,7 +63,7 @@ t2 <- getModificationTime f return (t2 >= t1) -forceZoneSigned :: Domain -> FilePath -> Property +forceZoneSigned :: Domain -> FilePath -> Property NoInfo forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do salt <- take 16 <$> saltSha1 let p = proc "dnssec-signzone" 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} -- | Docker support for propellor -- @@ -40,6 +40,7 @@ import Propellor hiding (init) import Propellor.Types.Docker +import Propellor.Types.CmdLine import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Shim as Shim @@ -55,12 +56,12 @@ import Data.List.Utils import qualified Data.Map as M -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["docker.io"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. -configured :: Property +configured :: Property HasInfo configured = prop `requires` installed where prop = withPrivData src anyContext $ \getcfg -> @@ -77,10 +78,10 @@ -- | A docker container. data Container = Container Image Host -instance Hostlike Container where +instance PropAccum Container where (Container i h) & p = Container i (h & p) (Container i h) &^ p = Container i (h &^ p) - getHost (Container _ h) = h + getProperties (Container _ h) = hostProperties h -- | Defines a Container with a given name, image, and properties. -- Properties can be added to configure the Container. @@ -105,8 +106,9 @@ -- Reverting this property ensures that the container is stopped and -- removed. docked :: Container -> RevertableProperty -docked ctr@(Container _ h) = RevertableProperty +docked ctr@(Container _ h) = (propigateContainerInfo ctr (go "docked" setup)) + (go "undocked" teardown) where cn = hostName h @@ -133,10 +135,14 @@ ] ] -propigateContainerInfo :: Container -> Property -> Property -propigateContainerInfo ctr@(Container _ h) p = - propigateInfo ctr p (<> dockerinfo) +propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo +propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p' where + p' = infoProperty + (propertyDesc p) + (propertySatisfy p) + (propertyInfo p <> dockerinfo) + (propertyChildren p) dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton (hostName h) h } @@ -164,7 +170,7 @@ -- that were not set up using propellor. -- -- Generally, should come after the properties for the desired containers. -garbageCollected :: Property +garbageCollected :: Property NoInfo garbageCollected = propertyList "docker garbage collected" [ gccontainers , gcimages @@ -180,7 +186,7 @@ -- Currently, this consists of making pam_loginuid lines optional in -- the pam config, to work around -- which affects docker 1.2.0. -tweaked :: Property +tweaked :: Property NoInfo tweaked = trivial $ cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"] `describe` "tweaked for docker" @@ -191,7 +197,7 @@ -- other GRUB_CMDLINE_LINUX_DEFAULT settings. -- -- Only takes effect after reboot. (Not automated.) -memoryLimited :: Property +memoryLimited :: Property NoInfo memoryLimited = "/etc/default/grub" `File.containsLine` cfg `describe` "docker memory limited" `onChange` cmdProperty "update-grub" [] @@ -208,44 +214,44 @@ type Image = String -- | Set custom dns server for container. -dns :: String -> Property +dns :: String -> Property HasInfo dns = runProp "dns" -- | Set container host name. -hostname :: String -> Property +hostname :: String -> Property HasInfo hostname = runProp "hostname" -- | Set name of container. -name :: String -> Property +name :: String -> Property HasInfo name = runProp "name" -- | Publish a container's port to the host -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> Property +publish :: String -> Property HasInfo publish = runProp "publish" -- | Expose a container's port without publishing it. -expose :: String -> Property +expose :: String -> Property HasInfo expose = runProp "expose" -- | Username or UID for container. -user :: String -> Property +user :: String -> Property HasInfo user = runProp "user" -- | Mount a volume -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] -- With just a directory, creates a volume in the container. -volume :: String -> Property +volume :: String -> Property HasInfo volume = runProp "volume" -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> Property +volumes_from :: ContainerName -> Property HasInfo volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) -- | Work dir inside the container. -workdir :: String -> Property +workdir :: String -> Property HasInfo workdir = runProp "workdir" -- | Memory limit for container. @@ -253,18 +259,18 @@ -- -- Note: Only takes effect when the host has the memoryLimited property -- enabled. -memory :: String -> Property +memory :: String -> Property HasInfo memory = runProp "memory" -- | CPU shares (relative weight). -- -- By default, all containers run at the same priority, but you can tell -- the kernel to give more CPU time to a container using this property. -cpuShares :: Int -> Property +cpuShares :: Int -> Property HasInfo cpuShares = runProp "cpu-shares" . show -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Property +link :: ContainerName -> ContainerAlias -> Property HasInfo link linkwith calias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias @@ -276,19 +282,19 @@ -- propellor; as well as keeping badly behaved containers running, -- it ensures that containers get started back up after reboot or -- after docker is upgraded. -restartAlways :: Property +restartAlways :: Property HasInfo restartAlways = runProp "restart" "always" -- | Docker will restart the container if it exits nonzero. -- If a number is provided, it will be restarted only up to that many -- times. -restartOnFailure :: Maybe Int -> Property +restartOnFailure :: Maybe Int -> Property HasInfo restartOnFailure Nothing = runProp "restart" "on-failure" restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) -- | Makes docker not restart a container when it exits -- Note that this includes not restarting it on boot! -restartNever :: Property +restartNever :: Property HasInfo restartNever = runProp "restart" "no" -- | A container is identified by its name, and the host @@ -322,12 +328,12 @@ myContainerSuffix :: String myContainerSuffix = ".propellor" -containerDesc :: ContainerId -> Property -> Property +containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p -runningContainer :: ContainerId -> Image -> [RunParam] -> Property +runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l @@ -442,7 +448,7 @@ -- | Once a container is running, propellor can be run inside -- it to provision it. -provisionContainer :: ContainerId -> Property +provisionContainer :: ContainerId -> Property NoInfo provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) let params = ["--continue", show $ toChain cid] @@ -472,7 +478,8 @@ changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do r <- runPropellor h $ ensureProperties $ - hostProperties h + map ignoreInfo $ + hostProperties h putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool @@ -481,7 +488,7 @@ startContainer :: ContainerId -> IO Bool startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] -stoppedContainer :: ContainerId -> Property +stoppedContainer :: ContainerId -> Property NoInfo stoppedContainer cid = containerDesc cid $ property desc $ ifM (liftIO $ elem cid <$> listContainers RunningContainers) ( liftIO cleanup `after` ensureProperty @@ -533,13 +540,13 @@ listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Property +runProp :: String -> RunParam -> Property HasInfo runProp field val = pureInfoProperty (param) $ dockerInfo $ mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where param = field++"="++val -genProp :: String -> (HostName -> RunParam) -> Property +genProp :: String -> (HostName -> RunParam) -> Property HasInfo genProp field mkval = pureInfoProperty field $ dockerInfo $ mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -9,7 +9,7 @@ type Line = String -- | Replaces all the content of a file. -hasContent :: FilePath -> [Line] -> Property +hasContent :: FilePath -> [Line] -> Property NoInfo f `hasContent` newcontent = fileProperty ("replace " ++ f) (\_oldcontent -> newcontent) f @@ -17,25 +17,25 @@ -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. -hasPrivContent :: IsContext c => FilePath -> c -> Property +hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f -- | Like hasPrivContent, but allows specifying a source --- for PrivData, rather than using PrivDataSourceFile. -hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property +-- for PrivData, rather than using PrivDataSourceFile . +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo hasPrivContentFrom = hasPrivContent' writeFileProtected -- | Leaves the file at its default or current mode, -- allowing "private" data to be read. -- -- Use with caution! -hasPrivContentExposed :: IsContext c => FilePath -> c -> Property +hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f -hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo hasPrivContentExposedFrom = hasPrivContent' writeFile -hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property HasInfo hasPrivContent' writer source f context = withPrivData source context $ \getcontent -> property desc $ getcontent $ \privcontent -> @@ -45,10 +45,10 @@ desc = "privcontent " ++ f -- | Ensures that a line is present in a file, adding it to the end if not. -containsLine :: FilePath -> Line -> Property +containsLine :: FilePath -> Line -> Property NoInfo f `containsLine` l = f `containsLines` [l] -containsLines :: FilePath -> [Line] -> Property +containsLines :: FilePath -> [Line] -> Property NoInfo f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f where go content = content ++ filter (`notElem` content) ls @@ -56,17 +56,17 @@ -- | Ensures that a line is not present in a file. -- Note that the file is ensured to exist, so if it doesn't, an empty -- file will be written. -lacksLine :: FilePath -> Line -> Property +lacksLine :: FilePath -> Line -> Property NoInfo f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f -- | Removes a file. Does not remove symlinks or non-plain-files. -notPresent :: FilePath -> Property +notPresent :: FilePath -> Property NoInfo notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ makeChange $ nukeFile f -fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo fileProperty = fileProperty' writeFile -fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) where go True = do @@ -86,12 +86,12 @@ setOwnerAndGroup f' (fileOwner s) (fileGroup s) -- | Ensures a directory exists. -dirExists :: FilePath -> Property +dirExists :: FilePath -> Property NoInfo dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d -- | Ensures that a file/dir has the specified owner and group. -ownerGroup :: FilePath -> UserName -> GroupName -> Property +ownerGroup :: FilePath -> UserName -> GroupName -> Property NoInfo ownerGroup f owner group = property (f ++ " owner " ++ og) $ do r <- ensureProperty $ cmdProperty "chown" [og, f] if r == FailedChange @@ -101,7 +101,7 @@ og = owner ++ ":" ++ group -- | Ensures that a file/dir has the specfied mode. -mode :: FilePath -> FileMode -> Property +mode :: FilePath -> FileMode -> Property NoInfo mode f v = property (f ++ " mode " ++ show v) $ do liftIO $ modifyFileMode f (\_old -> v) noChange 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 @@ -9,6 +9,7 @@ Target(..), Proto(..), Rules(..), + Port, ConnectionState(..) ) where @@ -21,10 +22,10 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["iptables"] -rule :: Chain -> Target -> Rules -> Property +rule :: Chain -> Target -> Rules -> Property NoInfo rule c t rs = property ("firewall rule: " <> show r) addIpTable where r = Rule c t rs diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -13,7 +13,7 @@ -- -- Note that reverting this property does not remove or stop inetd. daemonRunning :: FilePath -> RevertableProperty -daemonRunning exportdir = RevertableProperty setup unsetup +daemonRunning exportdir = setup unsetup where setup = containsLine conf (mkl "tcp4") `requires` @@ -23,7 +23,7 @@ `requires` Apt.serviceInstalledRunning "openbsd-inetd" `onChange` - Service.running "openbsd-inetd" + Service.reloaded "openbsd-inetd" `describe` ("git-daemon exporting " ++ exportdir) unsetup = lacksLine conf (mkl "tcp4") `requires` @@ -48,7 +48,7 @@ , exportdir ] -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["git"] type RepoUrl = String @@ -62,7 +62,7 @@ -- it will be recursively deleted first. -- -- A branch can be specified, to check out. -cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property +cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo cloned owner url dir mbranch = check originurl (property desc checkout) `requires` installed where @@ -98,7 +98,7 @@ data GitShared = Shared GroupName | SharedAll | NotShared -bareRepo :: FilePath -> UserName -> GitShared -> Property +bareRepo :: FilePath -> UserName -> GitShared -> Property NoInfo bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ dirExists repo : case gitshared of NotShared -> diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -6,7 +6,7 @@ import System.PosixCompat -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["gnupg"] -- A numeric id, or a description of the key, in a form understood by gpg. @@ -20,7 +20,7 @@ -- -- Recommend only using this for low-value dedicated role keys. -- No attempt has been made to scrub the key out of memory once it's used. -keyImported :: GpgKeyId -> UserName -> Property +keyImported :: GpgKeyId -> UserName -> Property HasInfo keyImported (GpgKeyId keyid) user = flagFile' prop genflag `requires` installed where diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs --- a/src/Propellor/Property/Group.hs +++ b/src/Propellor/Property/Group.hs @@ -4,7 +4,7 @@ type GID = Int -exists :: GroupName -> Maybe GID -> Property +exists :: GroupName -> Maybe GID -> Property NoInfo exists group' mgid = check test (cmdProperty "addgroup" $ args mgid) `describe` unwords ["group", group'] where diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -4,10 +4,10 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt --- | Eg, "hd0,0" or "xen/xvda1" +-- | Eg, \"hd0,0\" or \"xen/xvda1\" type GrubDevice = String --- | Eg, "/dev/sda" +-- | Eg, \"\/dev/sda\" type OSDevice = String type TimeoutSecs = Int @@ -21,7 +21,7 @@ -- This includes running update-grub, so that the grub boot menu is -- created. It will be automatically updated when kernel packages are -- installed. -installed :: BIOS -> Property +installed :: BIOS -> Property NoInfo installed bios = Apt.installed [pkg] `describe` "grub package installed" `before` @@ -43,7 +43,7 @@ -- on the device; it always does the work to reinstall it. It's a good idea -- to arrange for this property to only run once, by eg making it be run -- onChange after OS.cleanInstallOnce. -boots :: OSDevice -> Property +boots :: OSDevice -> Property NoInfo boots dev = cmdProperty "grub-install" [dev] `describe` ("grub boots " ++ dev) @@ -55,7 +55,7 @@ -- -- The rootdev should be in the form "hd0", while the bootdev is in the form -- "xen/xvda". -chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo chainPVGrub rootdev bootdev timeout = combineProperties desc [ File.dirExists "/boot/grub" , "/boot/grub/menu.lst" `File.hasContent` diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -6,7 +6,7 @@ import qualified Propellor.Property.User as User -- Clean up a system as installed by cloudatcost.com -decruft :: Property +decruft :: Property NoInfo decruft = propertyList "cloudatcost cleanup" [ Hostname.sane , "worked around grub/lvm boot bug #743126" ==> diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs --- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -18,7 +18,7 @@ -- If the power is cycled, the non-distro kernel still boots up. -- So, this property also checks if the running kernel is present in /boot, -- and if not, reboots immediately into a distro kernel. -distroKernel :: Property +distroKernel :: Property NoInfo distroKernel = propertyList "digital ocean distro kernel hack" [ Apt.installed ["grub-pc", "kexec-tools", "file"] , "/etc/default/kexec" `File.containsLines` diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -2,9 +2,18 @@ import Propellor import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.File as File +import Utility.FileMode -- | Linode's pv-grub-x86_64 does not currently support booting recent -- Debian kernels compressed with xz. This sets up pv-grub chaing to enable -- it. -chainPVGrub :: Grub.TimeoutSecs -> Property +chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" + +-- | Linode disables mlocate's cron job's execute permissions, +-- presumably to avoid disk IO. This ensures it's executable. +mlocateEnabled :: Property NoInfo +mlocateEnabled = "/etc/cron.daily/mlocate" + `File.mode` combineModes (readModes ++ executeModes) + diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -17,10 +17,10 @@ -- Also, the 127.0.0.1 line is set to localhost. Putting any -- other hostnames there is not best practices and can lead to annoying -- messages from eg, apache. -sane :: Property +sane :: Property NoInfo sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName) -setTo :: HostName -> Property +setTo :: HostName -> Property NoInfo setTo hn = combineProperties desc go where desc = "hostname " ++ hn @@ -46,7 +46,7 @@ -- | Makes contain search and domain lines for -- the domain that the hostname is in. -searchDomain :: Property +searchDomain :: Property NoInfo searchDomain = property desc (ensureProperty . go =<< asks hostName) where desc = "resolv.conf search and domain configured" diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Journald.hs @@ -0,0 +1,53 @@ +module Propellor.Property.Journald where +import Propellor +import qualified Propellor.Property.Systemd as Systemd +import Utility.DataUnits + +-- | Configures journald, restarting it so the changes take effect. +configured :: Systemd.Option -> String -> Property NoInfo +configured option value = + Systemd.configured "/etc/systemd/journald.conf" option value + `onChange` Systemd.restarted "systemd-journald" + +-- The string is parsed to get a data size. +-- Examples: "100 megabytes" or "0.5tb" +type DataSize = String + +configuredSize :: Systemd.Option -> DataSize -> Property NoInfo +configuredSize option s = case readSize dataUnits s of + Just sz -> configured option (systemdSizeUnits sz) + Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange + +systemMaxUse :: DataSize -> Property NoInfo +systemMaxUse = configuredSize "SystemMaxUse" + +runtimeMaxUse :: DataSize -> Property NoInfo +runtimeMaxUse = configuredSize "RuntimeMaxUse" + +systemKeepFree :: DataSize -> Property NoInfo +systemKeepFree = configuredSize "SystemKeepFree" + +runtimeKeepFree :: DataSize -> Property NoInfo +runtimeKeepFree = configuredSize "RuntimeKeepFree" + +systemMaxFileSize :: DataSize -> Property NoInfo +systemMaxFileSize = configuredSize "SystemMaxFileSize" + +runtimeMaxFileSize :: DataSize -> Property NoInfo +runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize" + +-- Generates size units as used in journald.conf. +systemdSizeUnits :: Integer -> String +systemdSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz) + where + cfgfileunits :: [Unit] + cfgfileunits = + [ Unit (p 6) "E" "exabyte" + , Unit (p 5) "P" "petabyte" + , Unit (p 4) "T" "terabyte" + , Unit (p 3) "G" "gigabyte" + , Unit (p 2) "M" "megabyte" + , Unit (p 1) "K" "kilobyte" + ] + p :: Integer -> Integer + p n = 1024^n diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/List.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Property.List ( + PropertyList(..), + PropertyListType, +) where + +import Propellor.Types +import Propellor.Engine +import Propellor.PropAccum + +import Data.Monoid + +class PropertyList l where + -- | Combines a list of properties, resulting in a single property + -- that when run will run each property in the list in turn, + -- and print out the description of each as it's run. Does not stop + -- on failure; does propigate overall success/failure. + -- + -- Note that Property HasInfo and Property NoInfo are not the same + -- type, and so cannot be mixed in a list. To make a list of + -- mixed types, which can also include RevertableProperty, + -- use `props`: + -- + -- > propertyList "foo" $ props + -- > & someproperty + -- > ! oldproperty + -- > & otherproperty + propertyList :: Desc -> l -> Property (PropertyListType l) + + -- | Combines a list of properties, resulting in one property that + -- ensures each in turn. Stops if a property fails. + combineProperties :: Desc -> l -> Property (PropertyListType l) + +-- | Type level function to calculate whether a PropertyList has Info. +type family PropertyListType t +type instance PropertyListType [Property HasInfo] = HasInfo +type instance PropertyListType [Property NoInfo] = NoInfo +type instance PropertyListType PropList = HasInfo + +instance PropertyList [Property NoInfo] where + propertyList desc ps = simpleProperty desc (ensureProperties ps) ps + combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps + +instance PropertyList [Property HasInfo] where + -- It's ok to use ignoreInfo here, because the ps are made the + -- child properties of the property, and so their info is visible + -- that way. + propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps + combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps + +instance PropertyList PropList where + propertyList desc = propertyList desc . getProperties + combineProperties desc = combineProperties desc . getProperties + +combineSatisfy :: [Property i] -> Result -> Propellor Result +combineSatisfy [] rs = return rs +combineSatisfy (l:ls) rs = do + r <- ensureProperty $ ignoreInfo l + case r of + FailedChange -> return FailedChange + _ -> combineSatisfy ls (r <> rs) 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,28 +3,93 @@ import Propellor import Propellor.Property.File -interfaces :: FilePath -interfaces = "/etc/network/interfaces" +type Interface = String +ifUp :: Interface -> Property NoInfo +ifUp iface = cmdProperty "ifup" [iface] + +-- | Resets /etc/network/interfaces to a clean and empty state, +-- containing just the standard loopback interface, and with +-- interfacesD enabled. +-- +-- This can be used as a starting point to defining other interfaces. +-- +-- No interfaces are brought up or down by this property. +cleanInterfacesFile :: Property NoInfo +cleanInterfacesFile = hasContent interfacesFile + [ "# Deployed by propellor, do not edit." + , "" + , "source-directory interfaces.d" + , "" + , "# The loopback network interface" + , "auto lo" + , "iface lo inet loopback" + ] + `describe` ("clean " ++ interfacesFile) + +-- | Writes a static interface file for the specified interface. +-- +-- The interface has to be up already. It could have been brought up by +-- DHCP, or by other means. The current ipv4 addresses +-- and routing configuration of the interface are written into the file. +-- +-- 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 +static iface = check (not <$> doesFileExist f) setup + `describe` desc + `requires` interfacesDEnabled + where + f = interfaceDFile iface + desc = "static " ++ iface + setup = property desc $ do + ls <- liftIO $ lines <$> readProcess "ip" + ["-o", "addr", "show", iface, "scope", "global"] + stanzas <- liftIO $ concat <$> mapM mkstanza ls + ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas + mkstanza ipline = case words ipline of + -- Note that the IP address is written CIDR style, so + -- the netmask does not need to be specified separately. + (_:iface':"inet":addr:_) | iface' == iface -> do + gw <- getgateway + return $ catMaybes + [ Just $ "iface " ++ iface ++ " inet static" + , Just $ "\taddress " ++ addr + , ("\tgateway " ++) <$> gw + ] + _ -> return [] + getgateway = do + rs <- lines <$> readProcess "ip" + ["route", "show", "scope", "global", "dev", iface] + return $ case words <$> headMaybe rs of + Just ("default":"via":gw:_) -> Just gw + _ -> Nothing + -- | 6to4 ipv6 connection, should work anywhere -ipv6to4 :: Property -ipv6to4 = fileProperty "ipv6to4" go interfaces +ipv6to4 :: Property NoInfo +ipv6to4 = hasContent (interfaceDFile "sit0") + [ "# Deployed by propellor, do not edit." + , "iface sit0 inet6 static" + , "\taddress 2002:5044:5531::1" + , "\tnetmask 64" + , "\tgateway ::192.88.99.1" + , "auto sit0" + ] + `describe` "ipv6to4" + `requires` interfacesDEnabled `onChange` ifUp "sit0" - where - go ls - | all (`elem` ls) stanza = ls - | otherwise = ls ++ stanza - stanza = - [ "# Automatically added by propeller" - , "iface sit0 inet6 static" - , "\taddress 2002:5044:5531::1" - , "\tnetmask 64" - , "\tgateway ::192.88.99.1" - , "auto sit0" - , "# End automatically added by propeller" - ] -type Interface = String +interfacesFile :: FilePath +interfacesFile = "/etc/network/interfaces" -ifUp :: Interface -> Property -ifUp iface = cmdProperty "ifup" [iface] +-- | A file in the interfaces.d directory. +interfaceDFile :: Interface -> FilePath +interfaceDFile iface = "/etc/network/interfaces.d" iface + +-- | Ensures that files in the the interfaces.d directory are used. +interfacesDEnabled :: Property NoInfo +interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d" + `describe` "interfaces.d directory enabled" diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -9,7 +9,7 @@ type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty -siteEnabled hn cf = RevertableProperty enable disable +siteEnabled hn cf = enable disable where enable = check test prop `describe` ("nginx site enabled " ++ hn) @@ -27,7 +27,7 @@ `requires` installed `onChange` reloaded -siteAvailable :: HostName -> ConfigFile -> Property +siteAvailable :: HostName -> ConfigFile -> Property NoInfo siteAvailable hn cf = ("nginx site available " ++ hn) ==> siteCfg hn `File.hasContent` (comment : cf) where @@ -42,11 +42,11 @@ siteValRelativeCfg :: HostName -> FilePath siteValRelativeCfg hn = "../sites-available/" ++ hn -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["nginx"] -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "nginx" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "nginx" 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 @@ -10,6 +10,7 @@ import Propellor import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Network as Network import qualified Propellor.Property.User as User import qualified Propellor.Property.File as File import qualified Propellor.Property.Reboot as Reboot @@ -51,7 +52,7 @@ -- > `onChange` propertyList "fixing up after clean install" -- > [ preserveNetwork -- > , preserveResolvConf --- > , preserverRootSshAuthorized +-- > , preserveRootSshAuthorized -- > , Apt.update -- > -- , Grub.boots "/dev/sda" -- > -- `requires` Grub.installed Grub.PC @@ -64,7 +65,7 @@ -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here -cleanInstallOnce :: Confirmation -> Property +cleanInstallOnce :: Confirmation -> Property NoInfo cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ go `requires` confirmed "clean install confirmed" confirmation where @@ -88,7 +89,7 @@ (Just u@(System (Ubuntu _) _)) -> debootstrap u _ -> error "os is not declared to be Debian or Ubuntu" - debootstrap targetos = ensureProperty $ toProp $ + debootstrap targetos = ensureProperty $ -- Ignore the os setting, and install debootstrap from -- source, since we don't know what OS we're running in yet. Debootstrap.built' Debootstrap.sourceInstall @@ -179,7 +180,7 @@ data Confirmation = Confirmed HostName -confirmed :: Desc -> Confirmation -> Property +confirmed :: Desc -> Confirmation -> Property NoInfo confirmed desc (Confirmed c) = property desc $ do hostname <- asks hostName if hostname /= c @@ -191,11 +192,21 @@ -- | is configured to bring up the network -- interface that currently has a default route configured, using -- the same (static) IP address. -preserveNetwork :: Property -preserveNetwork = undefined -- TODO +preserveNetwork :: Property NoInfo +preserveNetwork = go `requires` Network.cleanInterfacesFile + where + go = property "preserve network configuration" $ do + ls <- liftIO $ lines <$> readProcess "ip" + ["route", "list", "scope", "global"] + case words <$> headMaybe ls of + Just ("default":"via":_:"dev":iface:_) -> + ensureProperty $ Network.static iface + _ -> do + warningMessage "did not find any default ipv4 route" + return FailedChange -- | is copied from the old OS -preserveResolvConf :: Property +preserveResolvConf :: Property NoInfo preserveResolvConf = check (fileExist oldloc) $ property (newloc ++ " copied from old OS") $ do ls <- liftIO $ lines <$> readFile oldloc @@ -207,7 +218,7 @@ -- | has added to it any ssh keys that -- were authorized in the old OS. Any other contents of the file are -- retained. -preserveRootSshAuthorized :: Property +preserveRootSshAuthorized :: Property NoInfo preserveRootSshAuthorized = check (fileExist oldloc) $ property (newloc ++ " copied from old OS") $ do ks <- liftIO $ lines <$> readFile oldloc @@ -217,7 +228,7 @@ oldloc = oldOSDir ++ newloc -- Removes the old OS's backup from -oldOSRemoved :: Confirmation -> Property +oldOSRemoved :: Confirmation -> Property NoInfo oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ go `requires` confirmed "old OS backup removal confirmed" confirmation where diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -36,7 +36,7 @@ -- > `requires` Ssh.keyImported SshRsa "root" (Context hostname) -- -- How awesome is that? -backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo backup dir crontimes params numclients = backup' dir crontimes params numclients `requires` restored dir params @@ -46,7 +46,7 @@ -- -- The gpg secret key will be automatically imported -- into root's keyring using Propellor.Property.Gpg.keyImported -backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property +backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo backupEncrypted dir crontimes params numclients keyid = backup dir crontimes params' numclients `requires` Gpg.keyImported keyid "root" @@ -54,7 +54,7 @@ params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params -- | Does a backup, but does not automatically restore. -backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo backup' dir crontimes params numclients = cronjob `describe` desc where desc = dir ++ " backed up by obnam" @@ -80,7 +80,7 @@ -- -- The restore is performed atomically; restoring to a temp directory -- and then moving it to the directory. -restored :: FilePath -> [ObnamParam] -> Property +restored :: FilePath -> [ObnamParam] -> Property NoInfo restored dir params = property (dir ++ " restored by obnam") go `requires` installed where @@ -108,17 +108,17 @@ , return FailedChange ) -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["obnam"] -- | Ensures that a recent version of obnam gets installed. -- -- Only does anything for Debian Stable. -latestVersion :: Property +latestVersion :: Property NoInfo latestVersion = withOS "obnam latest version" $ \o -> case o of (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $ Apt.setSourcesListD (stablesources suite) "obnam" - `requires` toProp (Apt.trustsKey key) + `requires` Apt.trustsKey' key _ -> noChange where stablesources suite = 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 @@ -7,8 +7,8 @@ import Data.List -providerFor :: [UserName] -> String -> Property -providerFor users baseurl = propertyList desc $ +providerFor :: [UserName] -> String -> Property HasInfo +providerFor users baseurl = propertyList desc $ map toProp [ Apt.serviceInstalledRunning "apache2" , Apt.installed ["simpleid"] `onChange` Service.restarted "apache2" diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -1,21 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Postfix where import Propellor import qualified Propellor.Property.Apt as Apt -import Propellor.Property.File +import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.User as User import qualified Data.Map as M import Data.List import Data.Char -installed :: Property +installed :: Property NoInfo installed = Apt.serviceInstalledRunning "postfix" -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "postfix" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "postfix" -- | Configures postfix as a satellite system, which @@ -24,7 +27,7 @@ -- The smarthost may refuse to relay mail on to other domains, without -- futher coniguration/keys. But this should be enough to get cron job -- mail flowing to a place where it will be seen. -satellite :: Property +satellite :: Property NoInfo satellite = check (not <$> mainCfIsSet "relayhost") setup `requires` installed where @@ -45,13 +48,17 @@ -- | Sets up a file by running a property (which the filename is passed -- to). If the setup property makes a change, postmap will be run on the -- file, and postfix will be reloaded. -mappedFile :: FilePath -> (FilePath -> Property) -> Property +mappedFile + :: Combines (Property x) (Property NoInfo) + => FilePath + -> (FilePath -> Property x) + -> Property (CInfo x NoInfo) mappedFile f setup = setup f `onChange` cmdProperty "postmap" [f] -- | Run newaliases command, which should be done after changing -- . -newaliases :: Property +newaliases :: Property NoInfo newaliases = trivial $ cmdProperty "newaliases" [] -- | The main config file for postfix. @@ -59,7 +66,7 @@ mainCfFile = "/etc/postfix/main.cf" -- | Sets a main.cf name=value pair. Does not reload postfix immediately. -mainCf :: (String, String) -> Property +mainCf :: (String, String) -> Property NoInfo mainCf (name, value) = check notset set `describe` ("postfix main.cf " ++ setting) where @@ -77,8 +84,8 @@ (_, v) -> v parse [] = Nothing --- | Checks if a main.cf field is set. A field that is set to "" --- is considered not set. +-- | Checks if a main.cf field is set. A field that is set to +-- the empty string is considered not set. mainCfIsSet :: String -> IO Bool mainCfIsSet name = do v <- getMainCf name @@ -96,8 +103,8 @@ -- -- Note that multiline configurations that continue onto the next line -- are not currently supported. -dedupMainCf :: Property -dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile +dedupMainCf :: Property NoInfo +dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile dedupCf :: [String] -> [String] dedupCf ls = @@ -119,3 +126,33 @@ dedup c kc ((Right (k, v)):rest) = case M.lookup k kc of Just n | n > 1 -> dedup c (M.insert k (n - 1) kc) rest _ -> dedup (fmt k v:c) kc rest + +-- | Installs saslauthd and configures it for postfix, authenticating +-- against PAM. +-- +-- Does not configure postfix to use it; eg smtpd_sasl_auth_enable = yes +-- needs to be set to enable use. See +-- https://wiki.debian.org/PostfixAndSASL +saslAuthdInstalled :: Property NoInfo +saslAuthdInstalled = setupdaemon + `requires` Service.running "saslauthd" + `requires` postfixgroup + `requires` dirperm + `requires` Apt.installed ["sasl2-bin"] + `requires` smtpdconf + where + setupdaemon = "/etc/default/saslauthd" `File.containsLines` + [ "START=yes" + , "OPTIONS=\"-c -m " ++ dir ++ "\"" + ] + `onChange` Service.restarted "saslauthd" + smtpdconf = "/etc/postfix/sasl/smtpd.conf" `File.containsLines` + [ "pwcheck_method: saslauthd" + , "mech_list: PLAIN LOGIN" + ] + dirperm = check (not <$> doesDirectoryExist dir) $ + cmdProperty "dpkg-statoverride" + [ "--add", "root", "sasl", "710", dir ] + postfixgroup = "postfix" `User.hasGroup` "sasl" + `onChange` restarted + dir = "/var/spool/postfix/var/run/saslauthd" diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -11,7 +11,7 @@ type Conf = String confEnabled :: Conf -> ConfigFile -> RevertableProperty -confEnabled conf cf = RevertableProperty enable disable +confEnabled conf cf = enable disable where enable = check test prop `describe` ("prosody conf enabled " ++ conf) @@ -30,7 +30,7 @@ `requires` installed `onChange` reloaded -confAvailable :: Conf -> ConfigFile -> Property +confAvailable :: Conf -> ConfigFile -> Property NoInfo confAvailable conf cf = ("prosody conf available " ++ conf) ==> confAvailPath conf `File.hasContent` (comment : cf) where @@ -42,11 +42,11 @@ confValPath :: Conf -> FilePath confValPath conf = "/etc/prosody/conf.d" conf <.> "cfg.lua" -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["prosody"] -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "prosody" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "prosody" diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -3,7 +3,7 @@ import Propellor import Utility.SafeCommand -now :: Property +now :: Property NoInfo now = cmdProperty "reboot" [] `describe` "reboot now" @@ -14,7 +14,7 @@ -- -- The reboot can be forced to run, which bypasses the init system. Useful -- if the init system might not be running for some reason. -atEnd :: Bool -> (Result -> Bool) -> Property +atEnd :: Bool -> (Result -> Bool) -> Property NoInfo atEnd force resultok = property "scheduled reboot at end of propellor run" $ do endAction "rebooting" atend return NoChange diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Scheduled ( period , periodParse @@ -18,8 +20,8 @@ -- -- This uses the description of the Property to keep track of when it was -- last run. -period :: Property -> Recurrance -> Property -period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do +period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i +period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do lasttime <- liftIO $ getLastChecked (propertyDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow @@ -34,7 +36,7 @@ desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. -periodParse :: Property -> String -> Property +periodParse :: Property NoInfo -> String -> Property NoInfo periodParse prop s = case toRecurrance s of Just recurrance -> period prop recurrance Nothing -> property "periodParse" $ do diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -12,16 +12,16 @@ -- Note that due to the general poor state of init scripts, the best -- we can do is try to start the service, and if it fails, assume -- this means it's already running. -running :: ServiceName -> Property +running :: ServiceName -> Property NoInfo running = signaled "start" "running" -restarted :: ServiceName -> Property +restarted :: ServiceName -> Property NoInfo restarted = signaled "restart" "restarted" -reloaded :: ServiceName -> Property +reloaded :: ServiceName -> Property NoInfo reloaded = signaled "reload" "reloaded" -signaled :: String -> Desc -> ServiceName -> Property +signaled :: String -> Desc -> ServiceName -> Property NoInfo signaled cmd desc svc = property (desc ++ " " ++ svc) $ do void $ ensureProperty $ scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.SiteSpecific.GitAnnexBuilder where import Propellor @@ -7,7 +9,7 @@ import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.File as File import qualified Propellor.Property.Docker as Docker -import Propellor.Property.Cron (CronTimes) +import Propellor.Property.Cron (Times) builduser :: UserName builduser = "builder" @@ -23,54 +25,56 @@ type TimeOut = String -- eg, 5h -autobuilder :: Architecture -> CronTimes -> TimeOut -> Property -autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" - [ Apt.serviceInstalledRunning "cron" - , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $ - "git pull ; timeout " ++ timeout ++ " ./autobuild" +autobuilder :: Architecture -> Times -> TimeOut -> Property HasInfo +autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props + & Apt.serviceInstalledRunning "cron" + & Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir + ("git pull ; timeout " ++ timeout ++ " ./autobuild") + & rsyncpassword + where + context = Context ("gitannexbuilder " ++ arch) + pwfile = homedir "rsyncpassword" -- The builduser account does not have a password set, -- instead use the password privdata to hold the rsync server -- password used to upload the built image. - , withPrivData (Password builduser) context $ \getpw -> + rsyncpassword = withPrivData (Password builduser) context $ \getpw -> property "rsync password" $ getpw $ \pw -> do oldpw <- liftIO $ catchDefaultIO "" $ readFileStrict pwfile if pw /= oldpw then makeChange $ writeFile pwfile pw else noChange - ] - where - context = Context ("gitannexbuilder " ++ arch) - pwfile = homedir "rsyncpassword" -tree :: Architecture -> Property -tree buildarch = combineProperties "gitannexbuilder tree" - [ Apt.installed ["git"] +tree :: Architecture -> Property HasInfo +tree buildarch = combineProperties "gitannexbuilder tree" $ props + & Apt.installed ["git"] -- gitbuilderdir directory already exists when docker volume is used, -- but with wrong owner. - , File.dirExists gitbuilderdir - , File.ownerGroup gitbuilderdir builduser builduser - , check (not <$> (doesDirectoryExist (gitbuilderdir ".git"))) $ + & File.dirExists gitbuilderdir + & File.ownerGroup gitbuilderdir builduser builduser + & gitannexbuildercloned + & builddircloned + where + gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir ".git"))) $ userScriptProperty builduser [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir , "cd " ++ gitbuilderdir , "git checkout " ++ buildarch ] `describe` "gitbuilder setup" - , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser + builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser [ "git clone git://git-annex.branchable.com/ " ++ builddir ] - ] -buildDepsApt :: Property -buildDepsApt = combineProperties "gitannexbuilder build deps" - [ Apt.buildDep ["git-annex"] - , Apt.installed ["liblockfile-simple-perl"] - , buildDepsNoHaskellLibs - , "git-annex source build deps installed" ==> Apt.buildDepIn builddir - ] +buildDepsApt :: Property HasInfo +buildDepsApt = combineProperties "gitannexbuilder build deps" $ props + & Apt.buildDep ["git-annex"] + & Apt.installed ["liblockfile-simple-perl"] + & buildDepsNoHaskellLibs + & Apt.buildDepIn builddir + `describe` "git-annex source build deps installed" -buildDepsNoHaskellLibs :: Property +buildDepsNoHaskellLibs :: Property NoInfo buildDepsNoHaskellLibs = Apt.installed ["git", "rsync", "moreutils", "ca-certificates", "debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", @@ -82,7 +86,7 @@ -- Installs current versions of git-annex's deps from cabal, but only -- does so once. -cabalDeps :: Property +cabalDeps :: Property NoInfo cabalDeps = flagFile go cabalupdated where go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] @@ -98,17 +102,23 @@ & User.accountFor builduser & tree arch & buildDepsApt - & autobuilder arch (show buildminute ++ " * * * *") timeout + & autobuilder arch (Cron.Times $ show buildminute ++ " * * * *") timeout & Docker.tweaked -androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container +androidAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container androidAutoBuilderContainer dockerImage crontimes timeout = androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir & Apt.unattendedUpgrades & autobuilder "android" crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. -androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container +androidContainer + :: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i))) + => (System -> Docker.Image) + -> Docker.ContainerName + -> Property i + -> FilePath + -> Docker.Container androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name (dockerImage osver) & os osver @@ -156,7 +166,7 @@ & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") & Docker.tweaked -armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container +armelAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" (dockerImage $ System (Debian Unstable) "armel") & os (System (Debian Testing) "armel") diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -6,7 +6,7 @@ import Utility.SafeCommand -- | Clones Joey Hess's git home directory, and runs its fixups script. -installedFor :: UserName -> Property +installedFor :: UserName -> Property NoInfo installedFor user = check (not <$> hasGitDir user) $ property ("githome " ++ user) (go =<< liftIO (homedir user)) `requires` Apt.installed ["git"] diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -22,22 +22,18 @@ import System.Posix.Files import Data.String.Utils -oldUseNetServer :: [Host] -> Property -oldUseNetServer hosts = propertyList ("olduse.net server") - [ oldUseNetInstalled "oldusenet-server" - , Obnam.latestVersion - , Obnam.backup datadir "33 4 * * *" - [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" - , "--client-name=spool" - ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ - property "olduse.net spool in place" $ makeChange $ do +oldUseNetServer :: [Host] -> Property HasInfo +oldUseNetServer hosts = propertyList "olduse.net server" $ props + & Apt.installed ["leafnode"] + & oldUseNetInstalled "oldusenet-server" + & Obnam.latestVersion + & oldUseNetBackup + & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) + (property "olduse.net spool in place" $ makeChange $ do removeDirectoryRecursive newsspool createSymbolicLink (datadir "news") newsspool - , Apt.installed ["leafnode"] - , "/etc/news/leafnode/config" `File.hasContent` + ) + & "/etc/news/leafnode/config" `File.hasContent` [ "# olduse.net configuration (deployed by propellor)" , "expire = 1000000" -- no expiry via texpire , "server = " -- no upstream server @@ -45,17 +41,22 @@ , "allowSTRANGERS = 42" -- lets anyone connect , "nopost = 1" -- no new posting (just gather them) ] - , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" - , Apt.serviceInstalledRunning "openbsd-inetd" - , File.notPresent "/etc/cron.daily/leafnode" - , File.notPresent "/etc/cron.d/leafnode" - , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" + & "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" + & Apt.serviceInstalledRunning "openbsd-inetd" + & File.notPresent "/etc/cron.daily/leafnode" + & File.notPresent "/etc/cron.d/leafnode" + & Cron.niceJob "oldusenet-expire" (Cron.Times "11 1 * * *") "news" newsspool expirecommand + & Cron.niceJob "oldusenet-uucp" (Cron.Times "*/5 * * * *") "news" "/" uucpcommand + & Apache.siteEnabled "nntp.olduse.net" nntpcfg + where + newsspool = "/var/spool/news" + datadir = "/var/spool/oldusenet" + expirecommand = intercalate ";" [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" , "find -type d -empty | xargs --no-run-if-empty rmdir" ] - , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ - "/usr/bin/uucp " ++ datadir - , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False + uucpcommand = "/usr/bin/uucp " ++ datadir + nntpcfg = apachecfg "nntp.olduse.net" False [ " DocumentRoot " ++ datadir ++ "/" , " " , " Options Indexes FollowSymlinks" @@ -63,23 +64,27 @@ , Apache.allowAll , " " ] - ] - where - newsspool = "/var/spool/news" - datadir = "/var/spool/oldusenet" -oldUseNetShellBox :: Property -oldUseNetShellBox = propertyList "olduse.net shellbox" - [ oldUseNetInstalled "oldusenet" - , Service.running "shellinabox" - ] + oldUseNetBackup = Obnam.backup datadir (Cron.Times "33 4 * * *") + [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" + , "--client-name=spool" + , "--ssh-key=" ++ keyfile + ] Obnam.OnlyClient + `requires` Ssh.keyImported' (Just keyfile) SshRsa "root" (Context "olduse.net") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + keyfile = "/root/.ssh/olduse.net.key" -oldUseNetInstalled :: Apt.Package -> Property +oldUseNetShellBox :: Property HasInfo +oldUseNetShellBox = propertyList "olduse.net shellbox" $ props + & oldUseNetInstalled "oldusenet" + & Service.running "shellinabox" + +oldUseNetInstalled :: Apt.Package -> Property HasInfo oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ - propertyList ("olduse.net " ++ pkg) - [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") + propertyList ("olduse.net " ++ pkg) $ props + & Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") `describe` "olduse.net build deps" - , scriptProperty + & scriptProperty [ "rm -rf /root/tmp/oldusenet" -- idenpotency , "git clone git://olduse.net/ /root/tmp/oldusenet/source" , "cd /root/tmp/oldusenet/source/" @@ -88,12 +93,15 @@ , "apt-get -fy install" -- dependencies , "rm -rf /root/tmp/oldusenet" ] `describe` "olduse.net built" - ] - -kgbServer :: Property -kgbServer = propertyList desc - [ withOS desc $ \o -> case o of +kgbServer :: Property HasInfo +kgbServer = propertyList desc $ props + & installed + & File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext + `onChange` Service.restarted "kgb-bot" + where + desc = "kgb.kitenet.net setup" + installed = withOS desc $ \o -> case o of (Just (System (Debian Unstable) _)) -> ensureProperty $ propertyList desc [ Apt.serviceInstalledRunning "kgb-bot" @@ -102,58 +110,52 @@ `onChange` Service.running "kgb-bot" ] _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" - , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext - `onChange` Service.restarted "kgb-bot" - ] - where - desc = "kgb.kitenet.net setup" -mumbleServer :: [Host] -> Property -mumbleServer hosts = combineProperties hn - [ Apt.serviceInstalledRunning "mumble-server" - , Obnam.latestVersion - , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" - [ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam" +mumbleServer :: [Host] -> Property HasInfo +mumbleServer hosts = combineProperties hn $ props + & Apt.serviceInstalledRunning "mumble-server" + & Obnam.latestVersion + & Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *") + [ "--repository=sftp://2318@usw-s002.rsync.net/~/" ++ hn ++ ".obnam" , "--client-name=mumble" ] Obnam.OnlyClient `requires` Ssh.keyImported SshRsa "root" (Context hn) - `requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root" - , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] - ] + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + & trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]) where hn = "mumble.debian.net" -obnamLowMem :: Property +obnamLowMem :: Property NoInfo obnamLowMem = combineProperties "obnam tuned for low memory use" [ Obnam.latestVersion , "/etc/obnam.conf" `File.containsLines` [ "[config]" , "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)." - , "upload-queue-size = 128" - , "lru-size = 128" + , "upload-queue-size = 96" + , "lru-size = 96" ] ] -- git.kitenet.net and git.joeyh.name -gitServer :: [Host] -> Property -gitServer hosts = propertyList "git.kitenet.net setup" - [ Obnam.latestVersion - , Obnam.backupEncrypted "/srv/git" "33 3 * * *" +gitServer :: [Host] -> Property HasInfo +gitServer hosts = propertyList "git.kitenet.net setup" $ props + & Obnam.latestVersion + & Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *") [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" + , "--ssh-key=" ++ sshkey , "--client-name=wren" -- historical ] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1") - `requires` Ssh.keyImported SshRsa "root" (Context "git.kitenet.net") + `requires` Ssh.keyImported' (Just sshkey) SshRsa "root" (Context "git.kitenet.net") `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" `requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net") `requires` User.accountFor "family" - , Apt.installed ["git", "rsync", "gitweb"] - -- backport avoids channel flooding on branch merge - , Apt.installedBackport ["kgb-client"] - -- backport supports ssh event notification - , Apt.installedBackport ["git-annex"] - , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext - , toProp $ Git.daemonRunning "/srv/git" - , "/etc/gitweb.conf" `File.containsLines` + & Apt.installed ["git", "rsync", "gitweb"] + & Apt.installed ["git-annex"] + & Apt.installed ["kgb-client"] + & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext + `requires` File.dirExists "/etc/kgb-bot/" + & Git.daemonRunning "/srv/git" + & "/etc/gitweb.conf" `File.containsLines` [ "$projectroot = '/srv/git';" , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" , "# disable snapshot download; overloads server" @@ -161,21 +163,22 @@ ] `describe` "gitweb configured" -- Repos push on to github. - , Ssh.knownHost hosts "github.com" "joey" + & Ssh.knownHost hosts "github.com" "joey" -- I keep the website used for gitweb checked into git.. - , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing - , website "git.kitenet.net" - , website "git.joeyh.name" - , toProp $ Apache.modEnabled "cgi" - ] + & Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + & website "git.kitenet.net" + & website "git.joeyh.name" + & Apache.modEnabled "cgi" where - website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True + sshkey = "/root/.ssh/git.kitenet.net.key" + website hn = apacheSite hn True [ " DocumentRoot /srv/web/git.kitenet.net/" , " " , " Options Indexes ExecCGI FollowSymlinks" , " AllowOverride None" , " AddHandler cgi-script .cgi" , " DirectoryIndex index.cgi" + , Apache.allowAll , " " , "" , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" @@ -188,48 +191,50 @@ type AnnexUUID = String -- | A website, with files coming from a git-annex repository. -annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property -annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") - [ Git.cloned "joey" origin dir Nothing +annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo +annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props + & Git.cloned "joey" origin dir Nothing `onChange` setup - , alias hn - , postupdatehook `File.hasContent` + & alias hn + & postupdatehook `File.hasContent` [ "#!/bin/sh" , "exec git update-server-info" ] `onChange` (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) - , setupapache - ] + & setupapache where dir = "/srv/web/" ++ hn postupdatehook = dir ".git/hooks/post-update" setup = userScriptProperty "joey" setupscript setupscript = [ "cd " ++ shellEscape dir - , "git config annex.uuid " ++ shellEscape uuid + , "git annex reinit " ++ shellEscape uuid ] ++ map addremote remotes ++ [ "git annex get" , "git update-server-info" ] addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url - setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ + setupapache = apacheSite hn True [ " ServerAlias www."++hn , "" , " DocumentRoot /srv/web/"++hn , " " , " Options FollowSymLinks" , " AllowOverride None" + , Apache.allowAll , " " , " " , " Options Indexes FollowSymLinks ExecCGI" , " AllowOverride None" , " AddHandler cgi-script .cgi" , " DirectoryIndex index.html index.cgi" - , " Order allow,deny" - , " allow from all" + , Apache.allowAll , " " ] +apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty +apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle + apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile apachecfg hn withssl middle | withssl = vhost False ++ vhost True @@ -251,8 +256,7 @@ , " " , " Options Indexes MultiViews" , " AllowOverride None" - , " Order allow,deny" - , " Allow from all" + , Apache.allowAll , " " , "" ] @@ -268,71 +272,83 @@ , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" ] -gitAnnexDistributor :: Property -gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" - [ Apt.installed ["rsync"] - , File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") +gitAnnexDistributor :: Property HasInfo +gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props + & Apt.installed ["rsync"] + & File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") + & File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" + & "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" `onChange` Service.running "rsync" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" -- git-annex distribution signing key - , Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey" - ] + & Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey" where endpoint d = combineProperties ("endpoint " ++ d) [ File.dirExists d , File.ownerGroup d "joey" "joey" ] +downloads :: [Host] -> Property HasInfo +downloads hosts = annexWebSite "/srv/git/downloads.git" + "downloads.kitenet.net" + "840760dc-08f0-11e2-8c61-576b7e66acfd" + [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")] + `requires` Ssh.knownHost hosts "eubackup.kitenet.net" "joey" + +tmp :: Property HasInfo +tmp = propertyList "tmp.kitenet.net" $ props + & annexWebSite "/srv/git/joey/tmp.git" + "tmp.kitenet.net" + "26fd6e38-1226-11e2-a75f-ff007033bdba" + [] + & twitRss + & pumpRss + -- Twitter, you kill us. -twitRss :: Property -twitRss = combineProperties "twitter rss" - [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing - , check (not <$> doesFileExist (dir "twitRss")) $ - userScriptProperty "joey" - [ "cd " ++ dir - , "ghc --make twitRss" - ] - `requires` Apt.installed - [ "libghc-xml-dev" - , "libghc-feed-dev" - , "libghc-tagsoup-dev" - ] - , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" - , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" - ] +twitRss :: Property HasInfo +twitRss = combineProperties "twitter rss" $ props + & Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing + & check (not <$> doesFileExist (dir "twitRss")) compiled + & feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" + & feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" where dir = "/srv/web/tmp.kitenet.net/twitrss" - crontime = "15 * * * *" + crontime = Cron.Times "15 * * * *" feed url desc = Cron.job desc crontime "joey" dir $ "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") + compiled = userScriptProperty "joey" + [ "cd " ++ dir + , "ghc --make twitRss" + ] + `requires` Apt.installed + [ "libghc-xml-dev" + , "libghc-feed-dev" + , "libghc-tagsoup-dev" + ] -- Work around for expired ssl cert. --- (no longer expired, TODO remove this and change urls) -pumpRss :: Property -pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/" +pumpRss :: Property NoInfo +pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") "joey" "/srv/web/tmp.kitenet.net/" "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null" -ircBouncer :: Property -ircBouncer = propertyList "IRC bouncer" - [ Apt.installed ["znc"] - , User.accountFor "znc" - , File.dirExists (takeDirectory conf) - , File.hasPrivContent conf anyContext - , File.ownerGroup conf "znc" "znc" - , Cron.job "znconboot" "@reboot" "znc" "~" "znc" +ircBouncer :: Property HasInfo +ircBouncer = propertyList "IRC bouncer" $ props + & Apt.installed ["znc"] + & User.accountFor "znc" + & File.dirExists (takeDirectory conf) + & File.hasPrivContent conf anyContext + & File.ownerGroup conf "znc" "znc" + & Cron.job "znconboot" (Cron.Times "@reboot") "znc" "~" "znc" -- ensure running if it was not already - , trivial $ userScriptProperty "znc" ["znc || true"] + & trivial (userScriptProperty "znc" ["znc || true"]) `describe` "znc running" - ] where conf = "/home/znc/.znc/configs/znc.conf" -kiteShellBox :: Property +kiteShellBox :: Property NoInfo kiteShellBox = propertyList "kitenet.net shellinabox" [ Apt.installed ["shellinabox"] , File.hasContent "/etc/default/shellinabox" @@ -345,28 +361,34 @@ , Service.running "shellinabox" ] -githubBackup :: Property -githubBackup = propertyList "github-backup box" - [ Apt.installed ["github-backup", "moreutils"] - , let f = "/home/joey/.github-keys" - in File.hasPrivContent f anyContext - `onChange` File.ownerGroup f "joey" "joey" - , Cron.niceJob "github-backup run" "30 4 * * *" "joey" - "/home/joey/lib/backup" $ intercalate "&&" $ - [ "mkdir -p github" - , "cd github" - , ". $HOME/.github-keys" - , "github-backup joeyh" - ] - , Cron.niceJob "gitriddance" "30 4 * * *" "joey" - "/home/joey/lib/backup" $ intercalate "&&" $ - [ "cd github" - , ". $HOME/.github-keys" - ] ++ map gitriddance githubMirrors - ] +githubBackup :: Property HasInfo +githubBackup = propertyList "github-backup box" $ props + & Apt.installed ["github-backup", "moreutils"] + & githubKeys + & Cron.niceJob "github-backup run" (Cron.Times "30 4 * * *") "joey" + "/home/joey/lib/backup" backupcmd + & Cron.niceJob "gitriddance" (Cron.Times "30 4 * * *") "joey" + "/home/joey/lib/backup" gitriddancecmd where + backupcmd = intercalate "&&" $ + [ "mkdir -p github" + , "cd github" + , ". $HOME/.github-keys" + , "github-backup joeyh" + ] + gitriddancecmd = intercalate "&&" $ + [ "cd github" + , ". $HOME/.github-keys" + ] ++ map gitriddance githubMirrors gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" +githubKeys :: Property HasInfo +githubKeys = + let f = "/home/joey/.github-keys" + in File.hasPrivContent f anyContext + `onChange` File.ownerGroup f "joey" "joey" + + -- these repos are only mirrored on github, I don't want -- all the proprietary features githubMirrors :: [(String, String)] @@ -380,20 +402,20 @@ where plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests" -rsyncNetBackup :: [Host] -> Property -rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *" +rsyncNetBackup :: [Host] -> Property NoInfo +rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *") "joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "joey" -backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property -backupsBackedupTo hosts desthost destdir = Cron.niceJob desc - "1 1 * * 3" "joey" "/" cmd - `requires` Ssh.knownHost hosts desthost "joey" +backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property NoInfo +backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc + (Cron.Times "@reboot") "joey" "/" cmd + `requires` Ssh.knownHost hosts srchost "joey" where - desc = "backups copied to " ++ desthost ++ " weekly" - cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir + desc = "backups copied from " ++ srchost ++ " on boot" + cmd = "rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir srchost -obnamRepos :: [String] -> Property +obnamRepos :: [String] -> Property NoInfo obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) (mkbase : map mkrepo rs) where @@ -403,23 +425,22 @@ mkdir d = File.dirExists d `before` File.ownerGroup d "joey" "joey" -podcatcher :: Property -podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *" +podcatcher :: Property NoInfo +podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *") "joey" "/home/joey/lib/sound/podcasts" "xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update" `requires` Apt.installed ["git-annex", "myrepos"] -kiteMailServer :: Property -kiteMailServer = propertyList "kitenet.net mail server" - [ Postfix.installed - , Apt.installed ["postfix-pcre"] - , Apt.serviceInstalledRunning "postgrey" +kiteMailServer :: Property HasInfo +kiteMailServer = propertyList "kitenet.net mail server" $ props + & Postfix.installed + & Apt.installed ["postfix-pcre"] + & Apt.serviceInstalledRunning "postgrey" - , Apt.serviceInstalledRunning "spamassassin" - , "/etc/default/spamassassin" `File.containsLines` + & Apt.serviceInstalledRunning "spamassassin" + & "/etc/default/spamassassin" `File.containsLines` [ "# Propellor deployed" , "ENABLED=1" - , "CRON=1" , "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\"" , "CRON=1" , "NICE=\"--nicelevel 15\"" @@ -427,15 +448,15 @@ `describe` "spamd enabled" `requires` Apt.serviceInstalledRunning "cron" - , Apt.serviceInstalledRunning "spamass-milter" + & Apt.serviceInstalledRunning "spamass-milter" -- Add -m to prevent modifying messages Subject or body. - , "/etc/default/spamass-milter" `File.containsLine` + & "/etc/default/spamass-milter" `File.containsLine` "OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\"" `onChange` Service.restarted "spamass-milter" `describe` "spamass-milter configured" - , Apt.serviceInstalledRunning "amavisd-milter" - , "/etc/default/amavisd-milter" `File.containsLines` + & Apt.serviceInstalledRunning "amavisd-milter" + & "/etc/default/amavisd-milter" `File.containsLines` [ "# Propellor deployed" , "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock" , "MILTERSOCKETOWNER=\"postfix:postfix\"" @@ -443,12 +464,14 @@ ] `onChange` Service.restarted "amavisd-milter" `describe` "amavisd-milter configured for postfix" - , Apt.serviceInstalledRunning "clamav-freshclam" + & Apt.serviceInstalledRunning "clamav-freshclam" - , dkimInstalled + & dkimInstalled - , Apt.installed ["maildrop"] - , "/etc/maildroprc" `File.hasContent` + & Postfix.saslAuthdInstalled + + & Apt.installed ["maildrop"] + & "/etc/maildroprc" `File.hasContent` [ "# Global maildrop filter file (deployed with propellor)" , "DEFAULT=\"$HOME/Maildir\"" , "MAILBOX=\"$DEFAULT/.\"" @@ -462,19 +485,19 @@ ] `describe` "maildrop configured" - , "/etc/aliases" `File.hasPrivContentExposed` ctx + & "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases - , hasJoeyCAChain - , hasPostfixCert ctx + & hasJoeyCAChain + & hasPostfixCert ctx - , "/etc/postfix/mydomain" `File.containsLines` + & "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" , "/ikiwiki\\.info/\tOK" , "/joeyh\\.name/\tOK" ] `onChange` Postfix.reloaded `describe` "postfix mydomain file configured" - , "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` + & "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` -- Remove received lines for mails relayed from trusted -- clients. These can be a privacy violation, or trigger -- spam filters. @@ -486,16 +509,16 @@ ] `onChange` Postfix.reloaded `describe` "postfix obscure_client_relay file configured" - , Postfix.mappedFile "/etc/postfix/virtual" + & Postfix.mappedFile "/etc/postfix/virtual" (flip File.containsLines [ "# *@joeyh.name to joey" , "@joeyh.name\tjoey" ] ) `describe` "postfix virtual file configured" `onChange` Postfix.reloaded - , Postfix.mappedFile "/etc/postfix/relay_clientcerts" $ - flip File.hasPrivContentExposed ctx - , Postfix.mainCfFile `File.containsLines` + & Postfix.mappedFile "/etc/postfix/relay_clientcerts" + (flip File.hasPrivContentExposed ctx) + & Postfix.mainCfFile `File.containsLines` [ "myhostname = kitenet.net" , "mydomain = $myhostname" , "append_dot_mydomain = no" @@ -511,8 +534,13 @@ , "# Filter out client relay lines from headers." , "header_checks = pcre:$config_directory/obscure_client_relay.pcre" + , "# Password auth for relaying (used by errol)" + , "smtpd_sasl_auth_enable = yes" + , "smtpd_sasl_security_options = noanonymous" + , "smtpd_sasl_local_domain = kitenet.net" + , "# Enable postgrey." - , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" + , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_sasl_authenticated,,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" , "# Enable spamass-milter, amavis-milter, opendkim" , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" @@ -544,24 +572,24 @@ `onChange` Postfix.reloaded `describe` "postfix configured" - , Apt.serviceInstalledRunning "dovecot-imapd" - , Apt.serviceInstalledRunning "dovecot-pop3d" - , "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` + & Apt.serviceInstalledRunning "dovecot-imapd" + & Apt.serviceInstalledRunning "dovecot-pop3d" + & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` "mail_location = maildir:~/Maildir" `onChange` Service.reloaded "dovecot" `describe` "dovecot mail.conf" - , "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` + & "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` "!include auth-passwdfile.conf.ext" `onChange` Service.restarted "dovecot" `describe` "dovecot auth.conf" - , File.hasPrivContent dovecotusers ctx + & File.hasPrivContent dovecotusers ctx `onChange` (dovecotusers `File.mode` combineModes [ownerReadMode, groupReadMode]) - , File.ownerGroup dovecotusers "root" "dovecot" + & File.ownerGroup dovecotusers "root" "dovecot" - , Apt.installed ["mutt", "bsd-mailx", "alpine"] + & Apt.installed ["mutt", "bsd-mailx", "alpine"] - , pinescript `File.hasContent` + & pinescript `File.hasContent` [ "#!/bin/sh" , "# deployed with propellor" , "set -e" @@ -575,14 +603,13 @@ `onChange` (pinescript `File.mode` combineModes (readModes ++ executeModes)) `describe` "pine wrapper script" - , "/etc/pine.conf" `File.hasContent` + & "/etc/pine.conf" `File.hasContent` [ "# deployed with propellor" , "inbox-path={localhost/novalidate-cert/NoRsh}inbox" ] `describe` "pine configured to use local imap server" - , Apt.serviceInstalledRunning "mailman" - ] + & Apt.serviceInstalledRunning "mailman" where ctx = Context "kitenet.net" pinescript = "/usr/local/bin/pine" @@ -590,7 +617,7 @@ -- Configures postfix to relay outgoing mail to kitenet.net, with -- verification via tls cert. -postfixClientRelay :: Context -> Property +postfixClientRelay :: Context -> Property HasInfo postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` [ "relayhost = kitenet.net" , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" @@ -606,7 +633,7 @@ `requires` hasPostfixCert ctx -- Configures postfix to have the dkim milter, and no other milters. -dkimMilter :: Property +dkimMilter :: Property HasInfo dkimMilter = Postfix.mainCfFile `File.containsLines` [ "smtpd_milters = inet:localhost:8891" , "non_smtpd_milters = inet:localhost:8891" @@ -619,22 +646,22 @@ -- This does not configure postfix to use the dkim milter, -- nor does it set up domainkey DNS. -dkimInstalled :: Property -dkimInstalled = propertyList "opendkim installed" - [ Apt.serviceInstalledRunning "opendkim" - , File.dirExists "/etc/mail" - , File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") - , File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" - , "/etc/default/opendkim" `File.containsLine` - "SOCKET=\"inet:8891@localhost\"" - , "/etc/opendkim.conf" `File.containsLines` - [ "KeyFile /etc/mail/dkim.key" - , "SubDomains yes" - , "Domain *" - , "Selector mail" - ] - ] - `onChange` Service.restarted "opendkim" +dkimInstalled :: Property HasInfo +dkimInstalled = go `onChange` Service.restarted "opendkim" + where + go = propertyList "opendkim installed" $ props + & Apt.serviceInstalledRunning "opendkim" + & File.dirExists "/etc/mail" + & File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") + & File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" + & "/etc/default/opendkim" `File.containsLine` + "SOCKET=\"inet:8891@localhost\"" + & "/etc/opendkim.conf" `File.containsLines` + [ "KeyFile /etc/mail/dkim.key" + , "SubDomains yes" + , "Domain *" + , "Selector mail" + ] -- This is the dkim public key, corresponding with /etc/mail/dkim.key -- This value can be included in a domain's additional records to make @@ -642,37 +669,36 @@ domainKey :: (BindDomain, Record) domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") -hasJoeyCAChain :: Property +hasJoeyCAChain :: Property HasInfo hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` Context "joeyca.pem" -hasPostfixCert :: Context -> Property +hasPostfixCert :: Context -> Property HasInfo hasPostfixCert ctx = combineProperties "postfix tls cert installed" [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx ] -kitenetHttps :: Property -kitenetHttps = propertyList "kitenet.net https certs" - [ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx - , File.hasPrivContent "/etc/ssl/private/web.pem" ctx - , File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx - , toProp $ Apache.modEnabled "ssl" - ] +kitenetHttps :: Property HasInfo +kitenetHttps = propertyList "kitenet.net https certs" $ props + & File.hasPrivContent "/etc/ssl/certs/web.pem" ctx + & File.hasPrivContent "/etc/ssl/private/web.pem" ctx + & File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx + & Apache.modEnabled "ssl" where ctx = Context "kitenet.net" -- Legacy static web sites and redirections from kitenet.net to newer -- sites. -legacyWebSites :: Property -legacyWebSites = propertyList "legacy web sites" - [ Apt.serviceInstalledRunning "apache2" - , toProp $ Apache.modEnabled "rewrite" - , toProp $ Apache.modEnabled "cgi" - , toProp $ Apache.modEnabled "speling" - , userDirHtml - , kitenetHttps - , toProp $ Apache.siteEnabled "kitenet.net" $ apachecfg "kitenet.net" True +legacyWebSites :: Property HasInfo +legacyWebSites = propertyList "legacy web sites" $ props + & Apt.serviceInstalledRunning "apache2" + & Apache.modEnabled "rewrite" + & Apache.modEnabled "cgi" + & Apache.modEnabled "speling" + & userDirHtml + & kitenetHttps + & apacheSite "kitenet.net" True -- /var/www is empty [ "DocumentRoot /var/www" , "" @@ -759,8 +785,8 @@ , "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]" , "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]" ] - , alias "anna.kitenet.net" - , toProp $ Apache.siteEnabled "anna.kitenet.net" $ apachecfg "anna.kitenet.net" False + & alias "anna.kitenet.net" + & apacheSite "anna.kitenet.net" False [ "DocumentRoot /home/anna/html" , "" , " Options Indexes ExecCGI" @@ -768,9 +794,9 @@ , Apache.allowAll , "" ] - , alias "sows-ear.kitenet.net" - , alias "www.sows-ear.kitenet.net" - , toProp $ Apache.siteEnabled "sows-ear.kitenet.net" $ apachecfg "sows-ear.kitenet.net" False + & alias "sows-ear.kitenet.net" + & alias "www.sows-ear.kitenet.net" + & apacheSite "sows-ear.kitenet.net" False [ "ServerAlias www.sows-ear.kitenet.net" , "DocumentRoot /srv/web/sows-ear.kitenet.net" , "" @@ -779,9 +805,9 @@ , Apache.allowAll , "" ] - , alias "wortroot.kitenet.net" - , alias "www.wortroot.kitenet.net" - , toProp $ Apache.siteEnabled "wortroot.kitenet.net" $ apachecfg "wortroot.kitenet.net" False + & alias "wortroot.kitenet.net" + & alias "www.wortroot.kitenet.net" + & apacheSite "wortroot.kitenet.net" False [ "ServerAlias www.wortroot.kitenet.net" , "DocumentRoot /srv/web/wortroot.kitenet.net" , "" @@ -790,8 +816,8 @@ , Apache.allowAll , "" ] - , alias "creeksidepress.com" - , toProp $ Apache.siteEnabled "creeksidepress.com" $ apachecfg "creeksidepress.com" False + & alias "creeksidepress.com" + & apacheSite "creeksidepress.com" False [ "ServerAlias www.creeksidepress.com" , "DocumentRoot /srv/web/www.creeksidepress.com" , "" @@ -800,8 +826,8 @@ , Apache.allowAll , "" ] - , alias "joey.kitenet.net" - , toProp $ Apache.siteEnabled "joey.kitenet.net" $ apachecfg "joey.kitenet.net" False + & alias "joey.kitenet.net" + & apacheSite "joey.kitenet.net" False [ "DocumentRoot /var/www" , "" , " Options Indexes ExecCGI" @@ -821,12 +847,12 @@ , "# Redirect all to joeyh.name." , "rewriterule (.*) http://joeyh.name$1 [r]" ] - ] -userDirHtml :: Property +userDirHtml :: Property HasInfo userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf `onChange` Apache.reloaded `requires` (toProp $ Apache.modEnabled "userdir") where munge = replace "public_html" "html" conf = "/etc/apache2/mods-available/userdir.conf" + 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 @@ -1,4 +1,5 @@ module Propellor.Property.Ssh ( + PubKeyText, setSshdConfig, permitRootLogin, passwordAuthentication, @@ -11,6 +12,7 @@ pubKey, getPubKey, keyImported, + keyImported', knownHost, authorizedKeys, listenPort @@ -35,7 +37,7 @@ sshdConfig :: FilePath sshdConfig = "/etc/ssh/sshd_config" -setSshdConfig :: String -> Bool -> Property +setSshdConfig :: String -> Bool -> Property NoInfo setSshdConfig setting allowed = combineProperties "sshd config" [ sshdConfig `File.lacksLine` (sshline $ not allowed) , sshdConfig `File.containsLine` (sshline allowed) @@ -45,10 +47,10 @@ where sshline v = setting ++ " " ++ sshBool v -permitRootLogin :: Bool -> Property +permitRootLogin :: Bool -> Property NoInfo permitRootLogin = setSshdConfig "PermitRootLogin" -passwordAuthentication :: Bool -> Property +passwordAuthentication :: Bool -> Property NoInfo passwordAuthentication = setSshdConfig "PasswordAuthentication" dotDir :: UserName -> IO FilePath @@ -66,13 +68,13 @@ where go f = not . null <$> catchDefaultIO "" (readFile f) -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "ssh" -- | Blows away existing host keys and make new ones. -- Useful for systems installed from an image that might reuse host keys. -- A flag file is used to only ever do this once. -randomHostKeys :: Property +randomHostKeys :: Property NoInfo randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restarted where @@ -89,7 +91,7 @@ -- The corresponding private keys come from the privdata. -- -- Any host keysthat are not in the list are removed from the host. -hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo hostKeys ctx l = propertyList desc $ catMaybes $ map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] where @@ -100,19 +102,20 @@ removestale b = map (File.notPresent . flip keyFile b) staletypes cleanup | null staletypes || null l = Nothing - | otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $ - ensureProperty $ - combineProperties desc (removestale True ++ removestale False) - `onChange` restarted + | otherwise = Just $ toProp $ + property ("any other ssh host keys removed " ++ typelist staletypes) $ + ensureProperty $ + combineProperties desc (removestale True ++ removestale False) + `onChange` restarted -- | 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; -hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo hostKey context keytype pub = combineProperties desc [ pubKey keytype pub - , property desc $ install writeFile True pub + , toProp $ property desc $ install writeFile True pub , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> property desc $ getkey $ install writeFileProtected False ] @@ -136,7 +139,7 @@ -- | Indicates the host key that is used by a Host, but does not actually -- configure the host to use it. Normally this does not need to be used; -- use 'hostKey' instead. -pubKey :: SshKeyType -> PubKeyText -> Property +pubKey :: SshKeyType -> PubKeyText -> Property HasInfo pubKey t k = pureInfoProperty ("ssh pubkey known") $ mempty { _sshPubKey = M.singleton t k } @@ -145,13 +148,25 @@ -- | Sets up a user with a ssh private key and public key pair from the -- PrivData. -keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property -keyImported keytype user context = combineProperties desc +-- +-- If the user already has a private/public key, it is left unchanged. +keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property HasInfo +keyImported = keyImported' Nothing + +-- | A file can be speficied to write the key to somewhere other than +-- usual. Allows a user to have multiple keys for different roles. +keyImported' :: IsContext c => Maybe FilePath -> SshKeyType -> UserName -> c -> Property HasInfo +keyImported' dest keytype user context = combineProperties desc [ installkey (SshPubKey keytype user) (install writeFile ".pub") , installkey (SshPrivKey keytype user) (install writeFileProtected "") ] where - desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")" + desc = unwords $ catMaybes + [ Just user + , Just "has ssh key" + , dest + , Just $ "(" ++ fromKeyType keytype ++ ")" + ] installkey p a = withPrivData p context $ \getkey -> property desc $ getkey a install writer ext key = do @@ -166,9 +181,11 @@ , File.ownerGroup (takeDirectory f) user user ] ) - keyfile ext = do - home <- homeDirectory <$> getUserEntryForName user - return $ home ".ssh" "id_" ++ fromKeyType keytype ++ ext + keyfile ext = case dest of + Nothing -> do + home <- homeDirectory <$> getUserEntryForName user + return $ home ".ssh" "id_" ++ fromKeyType keytype ++ ext + Just f -> return $ f ++ ext fromKeyType :: SshKeyType -> String fromKeyType SshRsa = "rsa" @@ -176,9 +193,9 @@ fromKeyType SshEcdsa = "ecdsa" fromKeyType SshEd25519 = "ed25519" --- | Puts some host's ssh public key(s), as set using 'pubKey', +-- | Puts some host's ssh public key(s), as set using 'pubKey' or 'hostKey' -- into the known_hosts file for a user. -knownHost :: [Host] -> HostName -> UserName -> Property +knownHost :: [Host] -> HostName -> UserName -> Property NoInfo knownHost hosts hn user = property desc $ go =<< fromHost hosts hn getPubKey where @@ -190,6 +207,7 @@ , f `File.containsLines` (map (\k -> hn ++ " " ++ k) (M.elems m)) , File.ownerGroup f user user + , File.ownerGroup (takeDirectory f) user user ] go _ = do warningMessage $ "no configred pubKey for " ++ hn @@ -198,7 +216,7 @@ -- | Makes a user have authorized_keys from the PrivData -- -- This removes any other lines from the file. -authorizedKeys :: IsContext c => UserName -> c -> Property +authorizedKeys :: IsContext c => UserName -> c -> Property HasInfo authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> property (user ++ " has authorized_keys") $ get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user @@ -212,20 +230,25 @@ -- | Ensures that a user's authorized_keys contains a line. -- Any other lines in the file are preserved as-is. -authorizedKey :: UserName -> String -> Property -authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do +authorizedKey :: UserName -> String -> Property NoInfo +authorizedKey user l = property desc $ do f <- liftIO $ dotFile "authorized_keys" user - ensureProperty $ - f `File.containsLine` l + ensureProperty $ combineProperties desc + [ f `File.containsLine` l `requires` File.dirExists (takeDirectory f) `onChange` File.mode f (combineModes [ownerWriteMode, ownerReadMode]) + , File.ownerGroup f user user + , File.ownerGroup (takeDirectory f) user user + ] + where + desc = user ++ " has autorized_keys line " ++ l -- | Makes the ssh server listen on a given port, in addition to any other -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. listenPort :: Int -> RevertableProperty -listenPort port = RevertableProperty enable disable +listenPort port = enable disable where portline = "Port " ++ show port enable = sshdConfig `File.containsLine` portline diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs --- a/src/Propellor/Property/Sudo.hs +++ b/src/Propellor/Property/Sudo.hs @@ -9,7 +9,7 @@ -- | Allows a user to sudo. If the user has a password, sudo is configured -- to require it. If not, NOPASSWORD is enabled for the user. -enabledFor :: UserName -> Property +enabledFor :: UserName -> Property NoInfo enabledFor user = property desc go `requires` Apt.installed ["sudo"] where go = do 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 @@ -1,10 +1,16 @@ module Propellor.Property.Systemd ( module Propellor.Property.Systemd.Core, + ServiceName, + MachineName, started, stopped, enabled, disabled, + restarted, persistentJournal, + Option, + configured, + journaldConfigured, daemonReloaded, Container, container, @@ -33,33 +39,38 @@ data Container = Container MachineName Chroot.Chroot Host deriving (Show) -instance Hostlike Container where - (Container n c h) & p = Container n c (h & p) - (Container n c h) &^ p = Container n c (h &^ p) - getHost (Container _ _ h) = h +instance PropAccum Container where + (Container n c h) & p = Container n c (h & p) + (Container n c h) &^ p = Container n c (h &^ p) + getProperties (Container _ _ h) = hostProperties h -- | Starts a systemd service. -started :: ServiceName -> Property +started :: ServiceName -> Property NoInfo started n = trivial $ cmdProperty "systemctl" ["start", n] `describe` ("service " ++ n ++ " started") -- | Stops a systemd service. -stopped :: ServiceName -> Property +stopped :: ServiceName -> Property NoInfo stopped n = trivial $ cmdProperty "systemctl" ["stop", n] `describe` ("service " ++ n ++ " stopped") -- | Enables a systemd service. -enabled :: ServiceName -> Property +enabled :: ServiceName -> Property NoInfo enabled n = trivial $ cmdProperty "systemctl" ["enable", n] `describe` ("service " ++ n ++ " enabled") -- | Disables a systemd service. -disabled :: ServiceName -> Property +disabled :: ServiceName -> Property NoInfo disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") +-- | Restarts a systemd service. +restarted :: ServiceName -> Property NoInfo +restarted n = trivial $ cmdProperty "systemctl" ["restart", n] + `describe` ("service " ++ n ++ " restarted") + -- | Enables persistent storage of the journal. -persistentJournal :: Property +persistentJournal :: Property NoInfo persistentJournal = check (not <$> doesDirectoryExist dir) $ combineProperties "persistent systemd journal" [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] @@ -70,8 +81,35 @@ where dir = "/var/log/journal" +type Option = String + +-- | Ensures that an option is configured in one of systemd's config files. +-- 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. 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 +configured cfgfile option value = combineProperties desc + [ File.fileProperty desc (mapMaybe removeother) cfgfile + , File.containsLine cfgfile line + ] + where + setting = option ++ "=" + line = setting ++ value + desc = cfgfile ++ " " ++ line + removeother l + | setting `isPrefixOf` l = Nothing + | otherwise = Just l + +-- | Configures journald, restarting it so the changes take effect. +journaldConfigured :: Option -> String -> Property NoInfo +journaldConfigured option value = + configured "/etc/systemd/journald.conf" option value + `onChange` restarted "systemd-journald" + -- | Causes systemd to reload its configuration files. -daemonReloaded :: Property +daemonReloaded :: Property NoInfo daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"] -- | Defines a container with a given machine name. @@ -105,17 +143,12 @@ -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) = - RevertableProperty setup teardown + p `describe` ("nspawned " ++ name) where - setup = combineProperties ("nspawned " ++ name) $ - map toProp steps ++ [containerprovisioned] - teardown = combineProperties ("not nspawned " ++ name) $ - map (toProp . revert) (reverse steps) - steps = - [ enterScript c - , chrootprovisioned - , nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h) - ] + p = enterScript c + `before` chrootprovisioned + `before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h) + `before` containerprovisioned -- Chroot provisioning is run in systemd-only mode, -- which sets up the chroot and ensures systemd and dbus are @@ -125,15 +158,17 @@ -- Use nsenter to enter container and and run propellor to -- finish provisioning. - containerprovisioned = Chroot.propellChroot chroot - (enterContainerProcess c) False + containerprovisioned = + Chroot.propellChroot chroot (enterContainerProcess c) False + + doNothing chroot = Chroot.Chroot loc system builderconf h -- | Sets up the service file for the container, and then starts -- it running. nspawnService :: Container -> ChrootCfg -> RevertableProperty -nspawnService (Container name _ _) cfg = RevertableProperty setup teardown +nspawnService (Container name _ _) cfg = setup teardown where service = nspawnServiceName name servicefile = "/etc/systemd/system/multi-user.target.wants" service @@ -177,7 +212,7 @@ -- This uses nsenter to enter the container, by looking up the pid of the -- container's init process and using its namespace. enterScript :: Container -> RevertableProperty -enterScript c@(Container name _ _) = RevertableProperty setup teardown +enterScript c@(Container name _ _) = setup teardown where setup = combineProperties ("generated " ++ enterScriptFile c) [ scriptfile `File.hasContent` diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs --- a/src/Propellor/Property/Systemd/Core.hs +++ b/src/Propellor/Property/Systemd/Core.hs @@ -6,5 +6,5 @@ -- dbus is only a Recommends of systemd, but is needed for communication -- from the systemd inside a container to the one outside, so make sure it -- gets installed. -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["systemd", "dbus"] 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 @@ -7,21 +7,80 @@ import Utility.FileMode import System.Posix.Files +import Data.Char type HiddenServiceName = String -isBridge :: Property -isBridge = setup `requires` Apt.installed ["tor"] +type NodeName = String + +-- | Sets up a tor bridge. (Not a relay or exit node.) +-- +-- Uses port 443 +isBridge :: Property NoInfo +isBridge = isBridge' [] + +isBridge' :: [String] -> Property NoInfo +isBridge' extraconfig = server config `describe` "tor bridge" where - setup = mainConfig `File.hasContent` - [ "SocksPort 0" + config = + [ "BridgeRelay 1" + , "Exitpolicy reject *:*" , "ORPort 443" - , "BridgeRelay 1" + ] ++ extraconfig + +-- | Sets up a tor relay. +-- +-- Uses port 443 +isRelay :: Property NoInfo +isRelay = isRelay' [] + +isRelay' :: [String] -> Property NoInfo +isRelay' extraconfig = server config + `describe` "tor relay" + where + config = + [ "BridgeRelay 0" , "Exitpolicy reject *:*" - ] `onChange` restarted + , "ORPort 443" + ] ++ extraconfig -hiddenServiceAvailable :: HiddenServiceName -> Int -> Property +-- | Converts a property like isBridge' or isRelay' to be a named +-- node, with a known private key. +-- +-- This can be moved to a different IP without needing to wait to +-- accumulate trust. +-- +-- The base property can be used to start out and then upgraded to +-- a named property later. +named :: NodeName -> ([String] -> Property NoInfo) -> Property HasInfo +named n basep = p `describe` (getDesc p ++ " " ++ n) + where + p = basep ["Nickname " ++ saneNickname n] + `requires` torPrivKey (Context ("tor " ++ n)) + +-- | A tor server (bridge, relay, or exit) +-- Don't use if you just want to run tor for personal use. +server :: [String] -> Property NoInfo +server extraconfig = setup + `requires` Apt.installed ["tor", "ntp"] + `describe` "tor server" + where + setup = mainConfig `File.hasContent` config + `onChange` restarted + config = + [ "SocksPort 0" + ] ++ extraconfig + +torPrivKey :: Context -> Property HasInfo +torPrivKey context = f `File.hasPrivContent` context + `onChange` File.ownerGroup f user user + -- install tor first, so the directory exists with right perms + `requires` Apt.installed ["tor"] + where + f = "/var/lib/tor/keys/secret_id_key" + +hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo hiddenServiceAvailable hn port = hiddenServiceHostName prop where prop = mainConfig `File.containsLines` @@ -30,13 +89,13 @@ ] `describe` "hidden service available" `onChange` Service.reloaded "tor" - hiddenServiceHostName p = adjustProperty p $ \satisfy -> do + hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy h <- liftIO $ readFile (varLib hn "hostname") warningMessage $ unwords ["hidden service hostname:", h] return r -hiddenService :: HiddenServiceName -> Int -> Property +hiddenService :: HiddenServiceName -> Int -> Property NoInfo hiddenService hn port = mainConfig `File.containsLines` [ unwords ["HiddenServiceDir", varLib hn] , unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port] @@ -44,7 +103,7 @@ `describe` unwords ["hidden service available:", hn, show port] `onChange` restarted -hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property +hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo hiddenServiceData hn context = combineProperties desc [ installonion "hostname" , installonion "private_key" @@ -66,7 +125,7 @@ ] ) -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "tor" mainConfig :: FilePath @@ -80,3 +139,14 @@ user :: UserName user = "debian-tor" + +type NickName = String + +-- | Convert String to a valid tor NickName. +saneNickname :: String -> NickName +saneNickname s + | null n = "unnamed" + | otherwise = n + where + legal c = isNumber c || isAsciiUpper c || isAsciiLower c + n = take 19 $ filter legal s diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -6,7 +6,7 @@ data Eep = YesReallyDeleteHome -accountFor :: UserName -> Property +accountFor :: UserName -> Property NoInfo accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" [ "--disabled-password" , "--gecos", "" @@ -15,7 +15,7 @@ `describe` ("account for " ++ user) -- | Removes user home directory!! Use with caution. -nuked :: UserName -> Eep -> Property +nuked :: UserName -> Eep -> Property NoInfo nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" [ "-r" , user @@ -24,13 +24,13 @@ -- | Only ensures that the user has some password set. It may or may -- not be a password from the PrivData. -hasSomePassword :: UserName -> Property +hasSomePassword :: UserName -> Property HasInfo hasSomePassword user = hasSomePassword' user hostContext -- | While hasSomePassword uses the name of the host as context, -- this allows specifying a different context. This is useful when -- you want to use the same password on multiple hosts, for example. -hasSomePassword' :: IsContext c => UserName -> c -> Property +hasSomePassword' :: IsContext c => UserName -> c -> Property HasInfo hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $ hasPassword' user context @@ -40,10 +40,10 @@ -- A user's password can be stored in the PrivData in either of two forms; -- the full cleartext or a hash. The latter -- is obviously more secure. -hasPassword :: UserName -> Property +hasPassword :: UserName -> Property HasInfo hasPassword user = hasPassword' user hostContext -hasPassword' :: IsContext c => UserName -> c -> Property +hasPassword' :: IsContext c => UserName -> c -> Property HasInfo hasPassword' user context = go `requires` shadowConfig True where go = withSomePrivData srcs context $ @@ -66,7 +66,7 @@ hPutStrLn h $ user ++ ":" ++ v hClose h -lockedPassword :: UserName -> Property +lockedPassword :: UserName -> Property NoInfo lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" [ "--lock" , user @@ -90,7 +90,7 @@ homedir :: UserName -> IO FilePath homedir user = homeDirectory <$> getUserEntryForName user -hasGroup :: UserName -> GroupName -> Property +hasGroup :: UserName -> GroupName -> Property NoInfo hasGroup user group' = check test $ cmdProperty "adduser" [ user , group' @@ -100,7 +100,7 @@ test = not . elem group' . words <$> readProcess "groups" [user] -- | Controls whether shadow passwords are enabled or not. -shadowConfig :: Bool -> Property +shadowConfig :: Bool -> Property NoInfo shadowConfig True = check (not <$> shadowExists) $ cmdProperty "shadowconfig" ["on"] `describe` "shadow passwords enabled" diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -24,6 +24,7 @@ import Propellor.Git import Propellor.Ssh import Propellor.Gpg +import Propellor.Types.CmdLine import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,44 +1,48 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Propellor.Types ( Host(..) + , Desc + , Property + , HasInfo + , NoInfo + , CInfo + , infoProperty + , simpleProperty + , adjustPropertySatisfy + , propertyInfo + , propertyDesc + , propertyChildren + , RevertableProperty(..) + , () + , IsProp(..) + , Combines(..) + , CombinedType + , before + , combineWith , Info(..) - , getInfo , Propellor(..) - , Property(..) - , RevertableProperty(..) - , IsProp - , describe - , toProp - , requires - , Desc - , Result(..) - , ToResult(..) - , ActionResult(..) - , CmdLine(..) - , PrivDataField(..) - , PrivData - , Context(..) - , anyContext - , SshKeyType(..) - , Val(..) - , fromVal - , RunLog , EndAction(..) , module Propellor.Types.OS , module Propellor.Types.Dns + , module Propellor.Types.Result + , propertySatisfy + , ignoreInfo ) where import Data.Monoid import Control.Applicative -import System.Console.ANSI -import System.Posix.Types import "mtl" Control.Monad.RWS.Strict import "MonadCatchIO-transformers" Control.Monad.CatchIO import qualified Data.Set as S import qualified Data.Map as M -import qualified Propellor.Types.Dns as Dns import Propellor.Types.OS import Propellor.Types.Chroot @@ -46,137 +50,228 @@ import Propellor.Types.Docker import Propellor.Types.PrivData import Propellor.Types.Empty +import Propellor.Types.Val +import Propellor.Types.Result +import qualified Propellor.Types.Dns as Dns -- | Everything Propellor knows about a system: Its hostname, --- properties and other info. +-- properties and their collected info. data Host = Host { hostName :: HostName - , hostProperties :: [Property] + , hostProperties :: [Property HasInfo] , hostInfo :: Info } deriving (Show) -- | Propellor's monad provides read-only access to info about the host --- it's running on, and a writer to accumulate logs about the run. -newtype Propellor p = Propellor { runWithHost :: RWST Host RunLog () IO p } +-- it's running on, and a writer to accumulate EndActions. +newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } deriving ( Monad , Functor , Applicative , MonadReader Host - , MonadWriter RunLog + , MonadWriter [EndAction] , MonadIO , MonadCatchIO ) +instance Monoid (Propellor Result) where + mempty = return NoChange + -- | The second action is only run if the first action does not fail. + mappend x y = do + rx <- x + case rx of + FailedChange -> return FailedChange + _ -> do + ry <- y + return (rx <> ry) + +-- | An action that Propellor runs at the end, after trying to satisfy all +-- properties. It's passed the combined Result of the entire Propellor run. +data EndAction = EndAction Desc (Result -> Propellor Result) + +type Desc = String + -- | The core data type of Propellor, this represents a property -- that the system should have, and an action to ensure it has the -- property. -data Property = Property - { propertyDesc :: Desc - , propertySatisfy :: Propellor Result - -- ^ must be idempotent; may run repeatedly - , propertyInfo :: Info - -- ^ a property can add info to the host. - } +data Property i where + IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo + SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo -instance Show Property where - show p = "property " ++ show (propertyDesc p) +-- | Indicates that a Property has associated Info. +data HasInfo +-- | Indicates that a Property does not have Info. +data NoInfo +-- | Type level calculation of the combination of HasInfo and/or NoInfo +type family CInfo x y +type instance CInfo HasInfo HasInfo = HasInfo +type instance CInfo HasInfo NoInfo = HasInfo +type instance CInfo NoInfo HasInfo = HasInfo +type instance CInfo NoInfo NoInfo = NoInfo + +-- | Constructs a Property with associated Info. +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 + -> [Property i] -- ^ child properties + -> Property HasInfo +infoProperty d a i cs = IProperty d a i (map toIProperty cs) + +-- | Constructs a Property with no Info. +simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo +simpleProperty = SProperty + +toIProperty :: Property i -> Property HasInfo +toIProperty p@(IProperty {}) = p +toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs) + +toSProperty :: Property i -> Property NoInfo +toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs) +toSProperty p@(SProperty {}) = p + +-- | Makes a version of a Proprty without its Info. +-- Use with caution! +ignoreInfo :: Property i -> Property NoInfo +ignoreInfo = toSProperty + +-- | Gets the action that can be run to satisfy a Property. +-- You should never run this action directly. Use +-- 'Propellor.Engine.ensureProperty` instead. +propertySatisfy :: Property i -> Propellor Result +propertySatisfy (IProperty _ a _ _) = a +propertySatisfy (SProperty _ a _) = a + +instance Show (Property i) where + show p = "property " ++ show (propertyDesc p) + +-- | 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 + +propertyInfo :: Property i -> Info +propertyInfo (IProperty _ _ i _) = i +propertyInfo (SProperty {}) = mempty + +propertyDesc :: Property i -> Desc +propertyDesc (IProperty d _ _ _) = d +propertyDesc (SProperty d _ _) = d + +-- | A Property can include a list of child properties that it also +-- satisfies. This allows them to be introspected to collect their info, etc. +propertyChildren :: Property i -> [Property i] +propertyChildren (IProperty _ _ _ cs) = cs +propertyChildren (SProperty _ _ cs) = cs + -- | A property that can be reverted. -data RevertableProperty = RevertableProperty Property Property +data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo) +-- | Makes a revertable property; the first Property is run +-- normally and the second is run when it's reverted. +() :: Property i1 -> Property i2 -> RevertableProperty +p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2) + class IsProp p where -- | Sets description. describe :: p -> Desc -> p - toProp :: p -> Property - -- | Indicates that the first property can only be satisfied - -- once the second one is. - requires :: p -> Property -> p - getInfo :: p -> Info + toProp :: p -> Property HasInfo + getDesc :: p -> Desc + -- | Gets the info of the property, combined with all info + -- of all children properties. + getInfoRecursive :: p -> Info -instance IsProp Property where - describe p d = p { propertyDesc = d } - toProp p = p - getInfo = propertyInfo - x `requires` y = Property (propertyDesc x) satisfy info - where - info = getInfo y <> getInfo x - satisfy = do - r <- propertySatisfy y - case r of - FailedChange -> return FailedChange - _ -> propertySatisfy x - +instance IsProp (Property HasInfo) where + describe (IProperty _ a i cs) d = IProperty d a i cs + toProp = id + getDesc = propertyDesc + getInfoRecursive (IProperty _ _ i cs) = + i <> mconcat (map getInfoRecursive cs) +instance IsProp (Property NoInfo) where + describe (SProperty _ a cs) d = SProperty d a cs + toProp = toIProperty + getDesc = propertyDesc + getInfoRecursive _ = mempty instance IsProp RevertableProperty where -- | Sets the description of both sides. describe (RevertableProperty p1 p2) d = RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) + getDesc (RevertableProperty p1 _) = getDesc p1 toProp (RevertableProperty p1 _) = p1 - (RevertableProperty p1 p2) `requires` y = - RevertableProperty (p1 `requires` y) p2 -- | Return the Info of the currently active side. - getInfo (RevertableProperty p1 _p2) = getInfo p1 + getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 -type Desc = String +-- | Type level calculation of the type that results from combining two types +-- with `requires`. +type family CombinedType x y +type instance CombinedType (Property x) (Property y) = Property (CInfo x y) +type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty +type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty +type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty -data Result = NoChange | MadeChange | FailedChange - deriving (Read, Show, Eq) +class Combines x y where + -- | Indicates that the first property depends on the second, + -- so before the first is ensured, the second will be ensured. + requires :: x -> y -> CombinedType x y + +-- | Combines together two properties, resulting in one property +-- that ensures the first, and if the first succeeds, ensures the second. +-- The property uses the description of the first property. +before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x +before x y = (y `requires` x) `describe` (getDesc x) -instance Monoid Result where - mempty = NoChange +-- | 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. The two actions to satisfy the properties +-- are passed to a function that can combine them in arbitrary ways. +combineWith + :: (Combines (Property x) (Property y)) + => (Propellor Result -> Propellor Result -> Propellor Result) + -> Property x + -> Property y + -> CombinedType (Property x) (Property y) +combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ -> + f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y) - mappend FailedChange _ = FailedChange - mappend _ FailedChange = FailedChange - mappend MadeChange _ = MadeChange - mappend _ MadeChange = MadeChange - mappend NoChange NoChange = NoChange +instance Combines (Property HasInfo) (Property HasInfo) where + requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = + IProperty d1 (a2 <> a1) i1 (y : cs1) -class ToResult t where - toResult :: t -> Result +instance Combines (Property HasInfo) (Property NoInfo) where + requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = + IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1) -instance ToResult Bool where - toResult False = FailedChange - toResult True = MadeChange +instance Combines (Property NoInfo) (Property HasInfo) where + requires (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = + IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1) --- | Results of actions, with color. -class ActionResult a where - getActionResult :: a -> (String, ColorIntensity, Color) +instance Combines (Property NoInfo) (Property NoInfo) where + requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = + SProperty d1 (a2 <> a1) (y : cs1) -instance ActionResult Bool where - getActionResult False = ("failed", Vivid, Red) - getActionResult True = ("done", Dull, Green) +instance Combines RevertableProperty (Property HasInfo) where + requires (RevertableProperty p1 p2) y = + RevertableProperty (p1 `requires` y) p2 -instance ActionResult Result where - getActionResult NoChange = ("ok", Dull, Green) - getActionResult MadeChange = ("done", Vivid, Green) - getActionResult FailedChange = ("failed", Vivid, Red) +instance Combines RevertableProperty (Property NoInfo) where + requires (RevertableProperty p1 p2) y = + RevertableProperty (p1 `requires` toIProperty y) p2 -data CmdLine - = Run HostName - | Spin [HostName] (Maybe HostName) - | SimpleRun HostName - | Set PrivDataField Context - | Dump PrivDataField Context - | Edit PrivDataField Context - | ListFields - | AddKey String - | Merge - | Serialized CmdLine - | Continue CmdLine - | Update (Maybe HostName) - | Relay HostName - | DockerInit HostName - | DockerChain HostName String - | ChrootChain HostName FilePath Bool Bool - | GitPush Fd Fd - deriving (Read, Show, Eq) +instance Combines RevertableProperty RevertableProperty where + requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) = + RevertableProperty + (x1 `requires` y1) + -- when reverting, run actions in reverse order + (y2 `requires` x2) -- | Information about a host. data Info = Info { _os :: Val System - , _privDataFields :: S.Set (PrivDataField, HostContext) + , _privData :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) , _sshPubKey :: M.Map SshKeyType String , _aliases :: S.Set HostName , _dns :: S.Set Dns.Record @@ -190,7 +285,7 @@ mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty mappend old new = Info { _os = _os old <> _os new - , _privDataFields = _privDataFields old <> _privDataFields new + , _privData = _privData old <> _privData new , _sshPubKey = _sshPubKey new `M.union` _sshPubKey old , _aliases = _aliases old <> _aliases new , _dns = _dns old <> _dns new @@ -202,7 +297,7 @@ instance Empty Info where isEmpty i = and [ isEmpty (_os i) - , isEmpty (_privDataFields i) + , isEmpty (_privData i) , isEmpty (_sshPubKey i) , isEmpty (_aliases i) , isEmpty (_dns i) @@ -210,26 +305,3 @@ , isEmpty (_dockerinfo i) , isEmpty (_chrootinfo i) ] - -data Val a = Val a | NoVal - deriving (Eq, Show) - -instance Monoid (Val a) where - mempty = NoVal - mappend old new = case new of - NoVal -> old - _ -> new - -instance Empty (Val a) where - isEmpty NoVal = True - isEmpty _ = False - -fromVal :: Val a -> Maybe a -fromVal (Val a) = Just a -fromVal NoVal = Nothing - -type RunLog = [EndAction] - --- | An action that Propellor runs at the end, after trying to satisfy all --- properties. It's passed the combined Result of the entire Propellor run. -data EndAction = EndAction Desc (Result -> Propellor Result) diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/CmdLine.hs @@ -0,0 +1,27 @@ +module Propellor.Types.CmdLine where + +import Propellor.Types.OS +import Propellor.Types.PrivData + +import System.Posix.Types + +data CmdLine + = Run HostName + | Spin [HostName] (Maybe HostName) + | SimpleRun HostName + | Set PrivDataField Context + | Dump PrivDataField Context + | Edit PrivDataField Context + | ListFields + | AddKey String + | Merge + | Serialized CmdLine + | Continue CmdLine + | Update (Maybe HostName) + | Relay HostName + | DockerInit HostName + | DockerChain HostName String + | ChrootChain HostName FilePath Bool Bool + | GitPush Fd Fd + deriving (Read, Show, Eq) + diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs --- a/src/Propellor/Types/PrivData.hs +++ b/src/Propellor/Types/PrivData.hs @@ -24,9 +24,11 @@ | PrivDataSourceFileFromCommand PrivDataField FilePath String | PrivDataSource PrivDataField String +type PrivDataSourceDesc = String + class IsPrivDataSource s where privDataField :: s -> PrivDataField - describePrivDataSource :: s -> Maybe String + describePrivDataSource :: s -> Maybe PrivDataSourceDesc instance IsPrivDataSource PrivDataField where privDataField = id diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/Result.hs @@ -0,0 +1,37 @@ +module Propellor.Types.Result where + +import Data.Monoid +import System.Console.ANSI + +-- | There can be three results of satisfying a Property. +data Result = NoChange | MadeChange | FailedChange + deriving (Read, Show, Eq) + +instance Monoid Result where + mempty = NoChange + + mappend FailedChange _ = FailedChange + mappend _ FailedChange = FailedChange + mappend MadeChange _ = MadeChange + mappend _ MadeChange = MadeChange + mappend NoChange NoChange = NoChange + +class ToResult t where + toResult :: t -> Result + +instance ToResult Bool where + toResult False = FailedChange + toResult True = MadeChange + +-- | Results of actions, with color. +class ActionResult a where + getActionResult :: a -> (String, ColorIntensity, Color) + +instance ActionResult Bool where + getActionResult False = ("failed", Vivid, Red) + getActionResult True = ("done", Dull, Green) + +instance ActionResult Result where + getActionResult NoChange = ("ok", Dull, Green) + getActionResult MadeChange = ("done", Vivid, Green) + getActionResult FailedChange = ("failed", Vivid, Red) diff --git a/src/Propellor/Types/Val.hs b/src/Propellor/Types/Val.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/Val.hs @@ -0,0 +1,22 @@ +module Propellor.Types.Val where + +import Data.Monoid + +import Propellor.Types.Empty + +data Val a = Val a | NoVal + deriving (Eq, Show) + +instance Monoid (Val a) where + mempty = NoVal + mappend old new = case new of + NoVal -> old + _ -> new + +instance Empty (Val a) where + isEmpty NoVal = True + isEmpty _ = False + +fromVal :: Val a -> Maybe a +fromVal (Val a) = Just a +fromVal NoVal = Nothing diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs new file mode 100644 --- /dev/null +++ b/src/Utility/DataUnits.hs @@ -0,0 +1,161 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess + - + - License: BSD-2-clause + - + - + - And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + Unit(..), + + roughSize, + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +import Utility.HumanNumber + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gibibyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units short i + | i < 0 = '-' : findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = sortBy (flip compare) units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit x (Unit size abbrev name) = s ++ " " ++ unit + where + v = (fromInteger x :: Double) / fromInteger size + s = showImprecise 2 v + unit + | short = abbrev + | s == "1" = name + | otherwise = name ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum || null parsedunit = Nothing + | otherwise = Just $ round $ number * fromIntegral multiplier + where + (number, rest) = head parsednum + multiplier = head parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/src/Utility/HumanNumber.hs b/src/Utility/HumanNumber.hs new file mode 100644 --- /dev/null +++ b/src/Utility/HumanNumber.hs @@ -0,0 +1,21 @@ +{- numbers for humans + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.HumanNumber where + +{- Displays a fractional value as a string with a limited number + - of decimal digits. -} +showImprecise :: RealFrac a => Int -> a -> String +showImprecise precision n + | precision == 0 || remainder == 0 = show (round n :: Integer) + | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + where + int :: Integer + (int, frac) = properFraction n + remainder = round (frac * 10 ^ precision) :: Integer + pad0s s = replicate (precision - length s) '0' ++ s + striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs --- a/src/Utility/Table.hs +++ b/src/Utility/Table.hs @@ -16,13 +16,14 @@ where linesep = map (const '-') --- | Formats a table to lines, automatically padding rows to the same size. +-- | Formats a table to lines, automatically padding columns to the same size. formatTable :: Table -> [String] -formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table +formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table where pad (cell, size) = cell ++ take (size - length cell) padding padding = repeat ' ' - rowsizes = sumrows (map (map length) table) - sumrows [] = repeat 0 - sumrows [r] = r - sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs + colsizes = reverse $ (0:) $ drop 1 $ reverse $ + sumcols (map (map length) table) + sumcols [] = repeat 0 + sumcols [r] = r + sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs diff --git a/src/config.hs b/src/config.hs --- a/src/config.hs +++ b/src/config.hs @@ -33,7 +33,7 @@ & File.dirExists "/var/www" & Docker.docked webserverContainer & Docker.garbageCollected `period` Daily - & Cron.runPropellor "30 * * * *" + & Cron.runPropellor (Cron.Times "30 * * * *") -- add more hosts here... --, host "foo.example.com" = ...