packages feed

propellor 1.3.2 → 2.1.0

raw patch · 66 files changed

+1943/−1036 lines, 66 files

Files

CHANGELOG view
@@ -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 <id@joeyh.name>  Thu, 12 Feb 2015 12:36:26 -0400++propellor (2.0.0) unstable; urgency=medium++  * Property has been converted to a GADT, and will be Property NoInfo+    or Property HasInfo.+    This was done to make sure that ensureProperty is only used on+    properties that do not have Info.+    Transition guide:+    - Change all "Property" to "Property NoInfo" or "Property 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 <id@joeyh.name>  Sun, 25 Jan 2015 15:23:08 -0400+ propellor (1.3.2) unstable; urgency=medium    * SSHFP records are also generated for CNAMES of hosts.
config-joey.hs view
@@ -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             #     |     \ #                  >=)+    \______________________________# #   /       #__________________/ (-}++
config-simple.hs view
@@ -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" = ...
config.hs view
@@ -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" = ...
debian/changelog view
@@ -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 <id@joeyh.name>  Thu, 12 Feb 2015 12:36:26 -0400++propellor (2.0.0) unstable; urgency=medium++  * Property has been converted to a GADT, and will be Property NoInfo+    or Property HasInfo.+    This was done to make sure that ensureProperty is only used on+    properties that do not have Info.+    Transition guide:+    - Change all "Property" to "Property NoInfo" or "Property 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 <id@joeyh.name>  Sun, 25 Jan 2015 15:23:08 -0400+ propellor (1.3.2) unstable; urgency=medium    * SSHFP records are also generated for CNAMES of hosts.
debian/control view
@@ -18,7 +18,7 @@ 	libghc-monadcatchio-transformers-dev, Maintainer: Gergely Nagy <algernon@madhouse-project.org> 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
debian/copyright view
@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2014 Joey Hess <id@joeyh.name> and contributors+Copyright: © 2010-2015 Joey Hess <id@joeyh.name> and contributors License: BSD-2-clause  License: BSD-2-clause
propellor.cabal view
@@ -1,5 +1,5 @@ Name: propellor-Version: 1.3.2+Version: 2.1.0 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -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
src/Propellor.hs view
@@ -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://git.kitenet.net/propellor>+-- git clone <git://git.joeyh.name/propellor>  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
src/Propellor/CmdLine.hs view
@@ -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
src/Propellor/Engine.hs view
@@ -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
− src/Propellor/Host.hs 
@@ -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)
src/Propellor/Info.hs view
@@ -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]
src/Propellor/PrivData.hs view
@@ -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 ()
+ src/Propellor/PropAccum.hs view
@@ -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
src/Propellor/Property.hs view
@@ -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 ()
src/Propellor/Property/Apache.hs view
@@ -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 <Directory> -- stanza to allow global read access to the directory.
src/Propellor/Property/Apt.hs view
@@ -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 </etc/apt/sources.list.d/>-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"
src/Propellor/Property/Chroot.hs view
@@ -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"
src/Propellor/Property/Cmd.hs view
@@ -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)
src/Propellor/Property/Cron.hs view
@@ -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"
src/Propellor/Property/Debootstrap.hs view
@@ -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
src/Propellor/Property/Dns.hs view
@@ -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 $
src/Propellor/Property/DnsSec.hs view
@@ -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"
src/Propellor/Property/Docker.hs view
@@ -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 <https://github.com/docker/docker/issues/5663> -- 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)] }
src/Propellor/Property/File.hs view
@@ -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
src/Propellor/Property/Firewall.hs view
@@ -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
src/Propellor/Property/Git.hs view
@@ -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 ->
src/Propellor/Property/Gpg.hs view
@@ -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
src/Propellor/Property/Group.hs view
@@ -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
src/Propellor/Property/Grub.hs view
@@ -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`
src/Propellor/Property/HostingProvider/CloudAtCost.hs view
@@ -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" ==>
src/Propellor/Property/HostingProvider/DigitalOcean.hs view
@@ -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`
src/Propellor/Property/HostingProvider/Linode.hs view
@@ -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)+
src/Propellor/Property/Hostname.hs view
@@ -17,10 +17,10 @@ -- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any -- other hostnames there is not best practices and can lead to annoying -- messages from eg, apache.-sane :: Property+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 </etc/resolv.conf> 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"
+ src/Propellor/Property/Journald.hs view
@@ -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
+ src/Propellor/Property/List.hs view
@@ -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)
src/Propellor/Property/Network.hs view
@@ -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"
src/Propellor/Property/Nginx.hs view
@@ -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"
src/Propellor/Property/OS.hs view
@@ -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 @@ -- | </etc/network/interfaces> 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   -- | </etc/resolv.conf> 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 @@ -- | </root/.ssh/authorized_keys> 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 </old-os>-oldOSRemoved :: Confirmation -> Property+oldOSRemoved :: Confirmation -> Property NoInfo oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ 	go `requires` confirmed "old OS backup removal confirmed" confirmation   where
src/Propellor/Property/Obnam.hs view
@@ -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 =
src/Propellor/Property/OpenId.hs view
@@ -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"
src/Propellor/Property/Postfix.hs view
@@ -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 -- </etc/aliases>.-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"
src/Propellor/Property/Prosody.hs view
@@ -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"
src/Propellor/Property/Reboot.hs view
@@ -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
src/Propellor/Property/Scheduled.hs view
@@ -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
src/Propellor/Property/Service.hs view
@@ -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"]
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs view
@@ -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")
src/Propellor/Property/SiteSpecific/GitHome.hs view
@@ -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"]
src/Propellor/Property/SiteSpecific/JoeySites.hs view
@@ -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 ++ "/" 		, "  <Directory " ++ datadir ++ "/>" 		, "    Options Indexes FollowSymlinks"@@ -63,23 +64,27 @@ 		, Apache.allowAll 		, "  </Directory>" 		]-	]-  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/" 		, "  <Directory /srv/web/git.kitenet.net/>" 		, "    Options Indexes ExecCGI FollowSymlinks" 		, "    AllowOverride None" 		, "    AddHandler cgi-script .cgi" 		, "    DirectoryIndex index.cgi"+		, Apache.allowAll 		, "  </Directory>" 		, "" 		, "  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 		, "  <Directory /srv/web/"++hn++">" 		, "    Options FollowSymLinks" 		, "    AllowOverride None"+		, Apache.allowAll 		, "  </Directory>" 		, "  <Directory /srv/web/"++hn++">" 		, "    Options Indexes FollowSymLinks ExecCGI" 		, "    AllowOverride None" 		, "    AddHandler cgi-script .cgi" 		, "    DirectoryIndex index.html index.cgi"-		, "    Order allow,deny"-		, "    allow from all"+		, Apache.allowAll 		, "  </Directory>" 		] +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 @@ 		, "  <Directory \"/usr/share/apache2/icons\">" 		, "      Options Indexes MultiViews" 		, "      AllowOverride None"-		, "      Order allow,deny"-		, "      Allow from all"+		, Apache.allowAll 		, "  </Directory>" 		, "</VirtualHost>" 		]@@ -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" 		, "<Directory /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" 		, "<Directory /home/anna/html/>" 		, "  Options Indexes ExecCGI"@@ -768,9 +794,9 @@ 		, Apache.allowAll 		, "</Directory>" 		]-	, 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" 		, "<Directory /srv/web/sows-ear.kitenet.net>"@@ -779,9 +805,9 @@ 		, Apache.allowAll 		, "</Directory>" 		]-	, 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" 		, "<Directory /srv/web/wortroot.kitenet.net>"@@ -790,8 +816,8 @@ 		, Apache.allowAll 		, "</Directory>" 		]-	, 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" 		, "<Directory /srv/web/www.creeksidepress.com>"@@ -800,8 +826,8 @@ 		, Apache.allowAll 		, "</Directory>" 		]-	, 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" 		, "<Directory /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"+
src/Propellor/Property/Ssh.hs view
@@ -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
src/Propellor/Property/Sudo.hs view
@@ -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
src/Propellor/Property/Systemd.hs view
@@ -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`
src/Propellor/Property/Systemd/Core.hs view
@@ -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"]
src/Propellor/Property/Tor.hs view
@@ -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
src/Propellor/Property/User.hs view
@@ -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 <Password> or a <CryptPassword> 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"
src/Propellor/Spin.hs view
@@ -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
src/Propellor/Types.hs view
@@ -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)
+ src/Propellor/Types/CmdLine.hs view
@@ -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)+
src/Propellor/Types/PrivData.hs view
@@ -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
+ src/Propellor/Types/Result.hs view
@@ -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)
+ src/Propellor/Types/Val.hs view
@@ -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
+ src/Utility/DataUnits.hs view
@@ -0,0 +1,161 @@+{- data size display and parsing+ -+ - Copyright 2011 Joey Hess <id@joeyh.name>+ -+ - 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"
+ src/Utility/HumanNumber.hs view
@@ -0,0 +1,21 @@+{- numbers for humans+ -+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>+ -+ - 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
src/Utility/Table.hs view
@@ -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
src/config.hs view
@@ -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" = ...