propellor 2.17.2 → 3.0.0

raw patch · 102 files changed

+3061/−2550 lines, 102 filesdep +concurrent-outputPVP ok

version bump matches the API change (PVP)

Dependencies added: concurrent-output

API changes (from Hackage documentation)

Files

• CHANGELOG +79/−2
• README.md +8/−13
• config-freebsd.hs +6/−7
• config-simple.hs +2/−21
• config.hs +2/−21
• debian/changelog +79/−2
• debian/control +2/−0
• doc/README.mdwn +8/−13
• joeyconfig.hs +78/−72
• propellor.cabal +31/−18
• src/Propellor.hs +5/−4
• src/Propellor/Bootstrap.hs +50/−12
• src/Propellor/CmdLine.hs +7/−0
• src/Propellor/Container.hs +62/−0
• src/Propellor/DotDir.hs +393/−0
• src/Propellor/Engine.hs +12/−11
• src/Propellor/EnsureProperty.hs +70/−0
• src/Propellor/Gpg.hs +12/−5
• src/Propellor/Info.hs +84/−20
• src/Propellor/PrivData.hs +28/−17
• src/Propellor/PropAccum.hs +60/−62
• src/Propellor/Property.hs +97/−29
• src/Propellor/Property/Aiccu.hs +9/−7
• src/Propellor/Property/Apache.hs +27/−27
• src/Propellor/Property/Apt.hs +60/−64
• src/Propellor/Property/Apt/PPA.hs +115/−0
• src/Propellor/Property/Chroot.hs +50/−47
• src/Propellor/Property/Cmd.hs +5/−5
• src/Propellor/Property/Concurrent.hs +6/−8
• src/Propellor/Property/Conductor.hs +33/−24
• src/Propellor/Property/ConfFile.hs +4/−4
• src/Propellor/Property/Cron.hs +12/−13
• src/Propellor/Property/DebianMirror.hs +9/−11
• src/Propellor/Property/Debootstrap.hs +18/−24
• src/Propellor/Property/DiskImage.hs +53/−39
• src/Propellor/Property/Dns.hs +24/−21
• src/Propellor/Property/DnsSec.hs +7/−5
• src/Propellor/Property/Docker.hs +84/−77
• src/Propellor/Property/Fail2Ban.hs +4/−4
• src/Propellor/Property/File.hs +25/−24
• src/Propellor/Property/Firewall.hs +2/−2
• src/Propellor/Property/FreeBSD/Pkg.hs +10/−7
• src/Propellor/Property/FreeBSD/Poudriere.hs +12/−9
• src/Propellor/Property/Git.hs +12/−11
• src/Propellor/Property/Gpg.hs +3/−2
• src/Propellor/Property/Group.hs +1/−1
• src/Propellor/Property/Grub.hs +21/−18
• src/Propellor/Property/HostingProvider/CloudAtCost.hs +19/−14
• src/Propellor/Property/HostingProvider/DigitalOcean.hs +5/−6
• src/Propellor/Property/HostingProvider/Linode.hs +5/−4
• src/Propellor/Property/Hostname.hs +11/−10
• src/Propellor/Property/Journald.hs +8/−8
• src/Propellor/Property/Kerberos.hs +15/−14
• src/Propellor/Property/LetsEncrypt.hs +4/−3
• src/Propellor/Property/LightDM.hs +2/−4
• src/Propellor/Property/List.hs +40/−67
• src/Propellor/Property/Locale.hs +21/−17
• src/Propellor/Property/Logcheck.hs +2/−2
• src/Propellor/Property/Mount.hs +9/−8
• src/Propellor/Property/Network.hs +21/−17
• src/Propellor/Property/Nginx.hs +7/−7
• src/Propellor/Property/OS.hs +31/−20
• src/Propellor/Property/Obnam.hs +9/−8
• src/Propellor/Property/OpenId.hs +3/−3
• src/Propellor/Property/Parted.hs +8/−9
• src/Propellor/Property/Partition.hs +7/−5
• src/Propellor/Property/Postfix.hs +19/−18
• src/Propellor/Property/PropellorRepo.hs +1/−1
• src/Propellor/Property/Prosody.hs +6/−6
• src/Propellor/Property/Reboot.hs +3/−3
• src/Propellor/Property/Rsync.hs +3/−3
• src/Propellor/Property/Scheduled.hs +7/−6
• src/Propellor/Property/Service.hs +5/−5
• src/Propellor/Property/SiteSpecific/Branchable.hs +1/−1
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +54/−49
• src/Propellor/Property/SiteSpecific/GitHome.hs +6/−5
• src/Propellor/Property/SiteSpecific/IABak.hs +7/−6
• src/Propellor/Property/SiteSpecific/JoeySites.hs +101/−130
• src/Propellor/Property/Ssh.hs +105/−88
• src/Propellor/Property/Sudo.hs +5/−4
• src/Propellor/Property/Systemd.hs +96/−68
• src/Propellor/Property/Systemd/Core.hs +1/−1
• src/Propellor/Property/Tor.hs +23/−21
• src/Propellor/Property/Unbound.hs +4/−4
• src/Propellor/Property/User.hs +34/−29
• src/Propellor/Property/Uwsgi.hs +6/−6
• src/Propellor/Property/ZFS/Properties.hs +8/−4
• src/Propellor/Spin.hs +3/−3
• src/Propellor/Types.hs +128/−272
• src/Propellor/Types/CmdLine.hs +1/−0
• src/Propellor/Types/Core.hs +106/−0
• src/Propellor/Types/Info.hs +12/−3
• src/Propellor/Types/MetaTypes.hs +213/−0
• src/Propellor/Types/OS.hs +18/−3
• src/Propellor/Types/ResultCheck.hs +3/−0
• src/Propellor/Types/Singletons.hs +49/−0
• src/System/Console/Concurrent.hs +0/−44
• src/System/Console/Concurrent/Internal.hs +0/−556
• src/System/Process/Concurrent.hs +0/−34
• src/config.hs +2/−21
• src/wrapper.hs +20/−147
• stack.yaml +3/−0

@@ -1,3 +1,80 @@+propellor (3.0.0) unstable; urgency=medium++  * Property types have been improved to indicate what systems they target.+    This prevents using eg, Property FreeBSD on a Debian system.+    Transition guide for this sweeping API change:+    - First, upgrade to propellor 2.17.2 and deploy that to all your hosts.+      Otherwise, propellor --spin will fail when you upgrade to+      propellor 3.0.0.+    - Change "host name & foo & bar"+      to     "host name $ props & foo & bar"+    - Similarly, `propertyList` and `combineProperties` need `props`+      to be used to combine together properties; they no longer accept+      lists of properties. (If you have such a list, use `toProps`.)+    - And similarly, Chroot, Docker, and Systemd container need `props`+      to be used to combine together the properies used inside them.+    - The `os` property is removed. Instead use `osDebian`, `osBuntish`,+      or `osFreeBSD`. These tell the type checker the target OS of a host.+    - Change "Property NoInfo" to "Property UnixLike"+    - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"+    - Change "RevertableProperty NoInfo" to+      "RevertableProperty UnixLike UnixLike"+    - Change "RevertableProperty HasInfo" to+      "RevertableProperty (HasInfo + UnixLike) UnixLike"+    - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types.+      This is enabled by default for all modules in propellor.cabal. But+      if you are using propellor as a library, you may need to enable it+      manually.+    - If you know a property only works on a particular OS, like Debian+      or FreeBSD, use that instead of "UnixLike". For example:+      "Property Debian"+    - It's also possible make a property support a set of OS's, for example:+      "Property (Debian + FreeBSD)"+    - Removed `infoProperty` and `simpleProperty` constructors, instead use+      `property` to construct a Property.+    - Due to the polymorphic type returned by `property`, additional type+      signatures tend to be needed when using it. For example, this will+      fail to type check, because the type checker cannot guess what type+      you intend the intermediate property "go" to have:+        foo :: Property UnixLike+        foo = go `requires` bar+ 	  where+ 		go = property "foo" (return NoChange)+      To fix, specify the type of go:+ 	  	go :: Property UnixLike+    - `ensureProperty` now needs to be passed a witness to the type of the +      property it's used in.+      change this:  foo = property desc $ ... ensureProperty bar+      to this:      foo = property' desc $ \w -> ... ensureProperty w bar+    - General purpose properties like cmdProperty have type "Property UnixLike".+      When using that to run a command only available on Debian, you can+      tighten the type to only the OS that your more specific property works on.+      For example:+        upgraded :: Property Debian+        upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"])+    - Several utility functions have been renamed:+      getInfo to fromInfo+      propertyInfo to getInfo+      propertyDesc to getDesc+      propertyChildren to getChildren+  * The new `pickOS` property combinator can be used to combine different+    properties, supporting different OS's, into one Property that chooses+    which to use based on the Host's OS.+  * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling+    these complex new types.+  * Added dependency on concurrent-output; removed embedded copy.+  * Apt.PPA: New module, contributed by Evan Cofsky.+  * Improved propellor's first run experience; propellor --init will+    walk the user through setting up ~/.propellor, with a choice between+    a clone of propellor's git repository, or a minimal config, and will+    configure propellor to use a gpg key.+  * Stack support. "git config propellor.buildsystem stack" will make+    propellor build its config using stack.+  * When propellor is installed using stack, propellor --init will+    automatically set propellor.buildsystem=stack.++ -- Joey Hess <id@joeyh.name>  Sat, 02 Apr 2016 15:33:26 -0400+ propellor (2.17.2) unstable; urgency=medium    * When new dependencies are added to propellor or the propellor config,@@ -492,12 +569,12 @@     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"+    - Change all "Property" to "Property NoInfo" or "Property HasInfo"       (The compiler can tell you if you got it wrong!)     - To construct a RevertableProperty, it is useful to use the new       (<!>) operator     - Constructing a list of properties can be problimatic, since-      Property NoInto and Property WithInfo are different types and cannot+      Property NoInto and Property HasInfo are different types and cannot       appear in the same list. To deal with this, "props" has been added,       and can built up a list of properties of different types,       using the same (&) and (!) operators that are used to build

@@ -42,20 +42,15 @@      `cabal install propellor`           or      `apt-get install propellor`-2. Run `propellor` for the first time. It will set up a `~/.propellor/` git+2. Run `propellor --init` ; this will set up a `~/.propellor/` git    repository for you.-3. If you don't have a gpg private key already, generate one: `gpg --gen-key`-4. Run: `propellor --add-key $KEYID`, which will make propellor trust-   your gpg key, and will sign your `~/.propellor` repository using it.-5. Edit `~/.propellor/config.hs`, and add a host you want to manage.+3. Edit `~/.propellor/config.hs`, and add a host you want to manage.    You can start by not adding any properties, or only a few.-6. Run: `propellor --spin $HOST`-7. Now you have a simple propellor deployment, but it doesn't do-   much to the host yet, besides installing propellor.  -   So, edit `~/.propellor/config.hs` to configure the host, add some-   properties to it, and re-run step 6.  -   Repeat until happy and move on to the next host. :)-8. Once you have a lot of hosts, and running `propellor --spin HOST` for+4. Run: `propellor --spin $HOST`+5. Now you have a simple propellor deployment to a host. Continue editing+   `~/.propellor/config.hs` to further configure the host, add more hosts+   etc, and re-run `propellor --spin $HOST` after each change.  +6. Once you have a lot of hosts, and running `propellor --spin HOST` for    each host becomes tiresome, you can    [automate that](http://propellor.branchable.com/automated_spins/).-9. Write some neat new properties and send patches!+7. Write some neat new properties and send patches!

@@ -27,8 +27,8 @@  -- An example freebsd host. freebsdbox :: Host-freebsdbox = host "freebsdbox.example.com"-	& os (System (FreeBSD (FBSDProduction FBSD102)) "amd64")+freebsdbox = host "freebsdbox.example.com" $ props+	& osFreeBSD (FBSDProduction FBSD102) "amd64" 	& Pkg.update 	& Pkg.upgrade 	& Poudriere.poudriere poudriereZFS@@ -43,8 +43,8 @@  -- An example linux host. linuxbox :: Host-linuxbox = host "linuxbox.example.com"-	& os (System (Debian Unstable) "amd64")+linuxbox = host "linuxbox.example.com" $ props+	& osDebian Unstable "amd64" 	& Apt.stdSourcesList 	& Apt.unattendedUpgrades 	& Apt.installed ["etckeeper"]@@ -58,10 +58,9 @@  -- A generic webserver in a Docker container. webserverContainer :: Docker.Container-webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")-	& os (System (Debian (Stable "jessie")) "amd64")+webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props+	& osDebian (Stable "jessie") "amd64" 	& Apt.stdSourcesList 	& Docker.publish "80:80" 	& Docker.volume "/var/www:/var/www" 	& Apt.serviceInstalledRunning "apache2"-

@@ -4,15 +4,8 @@ import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Network as Network---import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Cron as Cron-import Propellor.Property.Scheduled---import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User---import qualified Propellor.Property.Hostname as Hostname---import qualified Propellor.Property.Tor as Tor-import qualified Propellor.Property.Docker as Docker  main :: IO () main = defaultMain hosts@@ -25,24 +18,12 @@  -- An example host. mybox :: Host-mybox = host "mybox.example.com"-	& os (System (Debian Unstable) "amd64")+mybox = host "mybox.example.com" $ props+	& osDebian Unstable "amd64" 	& Apt.stdSourcesList 	& Apt.unattendedUpgrades 	& Apt.installed ["etckeeper"] 	& Apt.installed ["ssh"] 	& User.hasSomePassword (User "root")-	& Network.ipv6to4 	& File.dirExists "/var/www"-	& Docker.docked webserverContainer-	& Docker.garbageCollected `period` Daily 	& Cron.runPropellor (Cron.Times "30 * * * *")---- A generic webserver in a Docker container.-webserverContainer :: Docker.Container-webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")-	& os (System (Debian (Stable "jessie")) "amd64")-	& Apt.stdSourcesList-	& Docker.publish "80:80"-	& Docker.volume "/var/www:/var/www"-	& Apt.serviceInstalledRunning "apache2"

@@ -4,15 +4,8 @@ import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Network as Network---import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Cron as Cron-import Propellor.Property.Scheduled---import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User---import qualified Propellor.Property.Hostname as Hostname---import qualified Propellor.Property.Tor as Tor-import qualified Propellor.Property.Docker as Docker  main :: IO () main = defaultMain hosts@@ -25,24 +18,12 @@  -- An example host. mybox :: Host-mybox = host "mybox.example.com"-	& os (System (Debian Unstable) "amd64")+mybox = host "mybox.example.com" $ props+	& osDebian Unstable "amd64" 	& Apt.stdSourcesList 	& Apt.unattendedUpgrades 	& Apt.installed ["etckeeper"] 	& Apt.installed ["ssh"] 	& User.hasSomePassword (User "root")-	& Network.ipv6to4 	& File.dirExists "/var/www"-	& Docker.docked webserverContainer-	& Docker.garbageCollected `period` Daily 	& Cron.runPropellor (Cron.Times "30 * * * *")---- A generic webserver in a Docker container.-webserverContainer :: Docker.Container-webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")-	& os (System (Debian (Stable "jessie")) "amd64")-	& Apt.stdSourcesList-	& Docker.publish "80:80"-	& Docker.volume "/var/www:/var/www"-	& Apt.serviceInstalledRunning "apache2"

@@ -1,3 +1,80 @@+propellor (3.0.0) unstable; urgency=medium++  * Property types have been improved to indicate what systems they target.+    This prevents using eg, Property FreeBSD on a Debian system.+    Transition guide for this sweeping API change:+    - First, upgrade to propellor 2.17.2 and deploy that to all your hosts.+      Otherwise, propellor --spin will fail when you upgrade to+      propellor 3.0.0.+    - Change "host name & foo & bar"+      to     "host name $ props & foo & bar"+    - Similarly, `propertyList` and `combineProperties` need `props`+      to be used to combine together properties; they no longer accept+      lists of properties. (If you have such a list, use `toProps`.)+    - And similarly, Chroot, Docker, and Systemd container need `props`+      to be used to combine together the properies used inside them.+    - The `os` property is removed. Instead use `osDebian`, `osBuntish`,+      or `osFreeBSD`. These tell the type checker the target OS of a host.+    - Change "Property NoInfo" to "Property UnixLike"+    - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"+    - Change "RevertableProperty NoInfo" to+      "RevertableProperty UnixLike UnixLike"+    - Change "RevertableProperty HasInfo" to+      "RevertableProperty (HasInfo + UnixLike) UnixLike"+    - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types.+      This is enabled by default for all modules in propellor.cabal. But+      if you are using propellor as a library, you may need to enable it+      manually.+    - If you know a property only works on a particular OS, like Debian+      or FreeBSD, use that instead of "UnixLike". For example:+      "Property Debian"+    - It's also possible make a property support a set of OS's, for example:+      "Property (Debian + FreeBSD)"+    - Removed `infoProperty` and `simpleProperty` constructors, instead use+      `property` to construct a Property.+    - Due to the polymorphic type returned by `property`, additional type+      signatures tend to be needed when using it. For example, this will+      fail to type check, because the type checker cannot guess what type+      you intend the intermediate property "go" to have:+        foo :: Property UnixLike+        foo = go `requires` bar+ 	  where+ 		go = property "foo" (return NoChange)+      To fix, specify the type of go:+ 	  	go :: Property UnixLike+    - `ensureProperty` now needs to be passed a witness to the type of the +      property it's used in.+      change this:  foo = property desc $ ... ensureProperty bar+      to this:      foo = property' desc $ \w -> ... ensureProperty w bar+    - General purpose properties like cmdProperty have type "Property UnixLike".+      When using that to run a command only available on Debian, you can+      tighten the type to only the OS that your more specific property works on.+      For example:+        upgraded :: Property Debian+        upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"])+    - Several utility functions have been renamed:+      getInfo to fromInfo+      propertyInfo to getInfo+      propertyDesc to getDesc+      propertyChildren to getChildren+  * The new `pickOS` property combinator can be used to combine different+    properties, supporting different OS's, into one Property that chooses+    which to use based on the Host's OS.+  * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling+    these complex new types.+  * Added dependency on concurrent-output; removed embedded copy.+  * Apt.PPA: New module, contributed by Evan Cofsky.+  * Improved propellor's first run experience; propellor --init will+    walk the user through setting up ~/.propellor, with a choice between+    a clone of propellor's git repository, or a minimal config, and will+    configure propellor to use a gpg key.+  * Stack support. "git config propellor.buildsystem stack" will make+    propellor build its config using stack.+  * When propellor is installed using stack, propellor --init will+    automatically set propellor.buildsystem=stack.++ -- Joey Hess <id@joeyh.name>  Sat, 02 Apr 2016 15:33:26 -0400+ propellor (2.17.2) unstable; urgency=medium    * When new dependencies are added to propellor or the propellor config,@@ -492,12 +569,12 @@     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"+    - Change all "Property" to "Property NoInfo" or "Property HasInfo"       (The compiler can tell you if you got it wrong!)     - To construct a RevertableProperty, it is useful to use the new       (<!>) operator     - Constructing a list of properties can be problimatic, since-      Property NoInto and Property WithInfo are different types and cannot+      Property NoInto and Property HasInfo are different types and cannot       appear in the same list. To deal with this, "props" has been added,       and can built up a list of properties of different types,       using the same (&) and (!) operators that are used to build

@@ -18,6 +18,7 @@ 	libghc-exceptions-dev (>= 0.6), 	libghc-stm-dev, 	libghc-text-dev,+	libghc-concurrent-output-dev, Maintainer: Joey Hess <id@joeyh.name> Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor@@ -41,6 +42,7 @@ 	libghc-exceptions-dev (>= 0.6), 	libghc-stm-dev, 	libghc-text-dev,+	libghc-concurrent-output-dev, 	git, 	make, Description: property-based host configuration management in haskell

@@ -42,20 +42,15 @@      `cabal install propellor`           or      `apt-get install propellor`-2. Run `propellor` for the first time. It will set up a `~/.propellor/` git+2. Run `propellor --init` ; this will set up a `~/.propellor/` git    repository for you.-3. If you don't have a gpg private key already, generate one: `gpg --gen-key`-4. Run: `propellor --add-key $KEYID`, which will make propellor trust-   your gpg key, and will sign your `~/.propellor` repository using it.-5. Edit `~/.propellor/config.hs`, and add a host you want to manage.+3. Edit `~/.propellor/config.hs`, and add a host you want to manage.    You can start by not adding any properties, or only a few.-6. Run: `propellor --spin $HOST`-7. Now you have a simple propellor deployment, but it doesn't do-   much to the host yet, besides installing propellor.  -   So, edit `~/.propellor/config.hs` to configure the host, add some-   properties to it, and re-run step 6.  -   Repeat until happy and move on to the next host. :)-8. Once you have a lot of hosts, and running `propellor --spin HOST` for+4. Run: `propellor --spin $HOST`+5. Now you have a simple propellor deployment to a host. Continue editing+   `~/.propellor/config.hs` to further configure the host, add more hosts+   etc, and re-run `propellor --spin $HOST` after each change.  +6. Once you have a lot of hosts, and running `propellor --spin HOST` for    each host becomes tiresome, you can    [automate that](http://propellor.branchable.com/automated_spins/).-9. Write some neat new properties and send patches!+7. Write some neat new properties and send patches!

@@ -43,7 +43,7 @@   {- Propellor            -- \          / | /    )          _.-"-._      Deployed -}          --  `/-==__ _/__|/__=-|          (       \_ hosts :: [Host]          --   *             \ | |           '--------'-hosts =                --                  (o)  `+hosts =                 --                  (o)  ` 	[ darkstar 	, gnu  	, clam@@ -59,24 +59,26 @@ 	] ++ monsters  testvm :: Host-testvm = host "testvm.kitenet.net"-	& os (System (Debian Unstable) "amd64")+testvm = host "testvm.kitenet.net" $ props+	& osDebian Unstable "amd64" 	& OS.cleanInstallOnce (OS.Confirmed "testvm.kitenet.net")-	 	`onChange` propertyList "fixing up after clean install"-	 		[ OS.preserveRootSshAuthorized-			, OS.preserveResolvConf-			, Apt.update-			, Grub.boots "/dev/sda"-				`requires` Grub.installed Grub.PC-	 		]+	 	`onChange` postinstall 	& Hostname.sane 	& Hostname.searchDomain 	& Apt.installed ["linux-image-amd64"] 	& Apt.installed ["ssh"] 	& User.hasPassword (User "root")+  where+	postinstall :: Property DebianLike+	postinstall = propertyList "fixing up after clean install" $ props+		& OS.preserveRootSshAuthorized+		& OS.preserveResolvConf+		& Apt.update+		& Grub.boots "/dev/sda"+			`requires` Grub.installed Grub.PC  darkstar :: Host-darkstar = host "darkstar.kitenet.net"+darkstar = host "darkstar.kitenet.net" $ props 	& ipv6 "2001:4830:1600:187::2" 	& Aiccu.hasConfig "T18376" "JHZ2-SIXXS" @@ -95,22 +97,23 @@ 		, swapPartition (MegaBytes 256) 		]   where-	c d = Chroot.debootstrapped mempty d-		& os (System (Debian Unstable) "amd64")+	c d = Chroot.debootstrapped mempty d $ props+		& osDebian Unstable "amd64" 		& Hostname.setTo "demo" 		& Apt.installed ["linux-image-amd64"] 		& User "root" `User.hasInsecurePassword` "root"  gnu :: Host-gnu = host "gnu.kitenet.net"+gnu = host "gnu.kitenet.net" $ props 	& Apt.buildDep ["git-annex"] `period` Daily  	& JoeySites.postfixClientRelay (Context "gnu.kitenet.net") 	& JoeySites.dkimMilter  clam :: Host-clam = standardSystem "clam.kitenet.net" Unstable "amd64"-	[ "Unreliable server. Anything here may be lost at any time!" ]+clam = host "clam.kitenet.net" $ props+	& standardSystem Unstable "amd64" +		["Unreliable server. Anything here may be lost at any time!" ] 	& ipv4 "167.88.41.194"  	& CloudAtCost.decruft@@ -141,8 +144,9 @@ 	& alias "us.scroll.joeyh.name"  mayfly :: Host-mayfly = standardSystem "mayfly.kitenet.net" (Stable "jessie") "amd64"-	[ "Scratch VM. Contents can change at any time!" ]+mayfly = host "mayfly.kitenet.net" $ props+	& standardSystem (Stable "jessie") "amd64"+		[ "Scratch VM. Contents can change at any time!" ] 	& ipv4 "167.88.36.193"  	& CloudAtCost.decruft@@ -156,8 +160,9 @@ 	& Tor.bandwidthRate (Tor.PerMonth "400 GB")  oyster :: Host-oyster = standardSystem "oyster.kitenet.net" Unstable "amd64"-	[ "Unreliable server. Anything here may be lost at any time!" ]+oyster = host "oyster.kitenet.net" $ props+	& standardSystem Unstable "amd64"+		[ "Unreliable server. Anything here may be lost at any time!" ] 	& ipv4 "104.167.117.109"  	& CloudAtCost.decruft@@ -179,8 +184,8 @@ 	& Ssh.listenPort (Port 80)  orca :: Host-orca = standardSystem "orca.kitenet.net" Unstable "amd64"-	[ "Main git-annex build box." ]+orca = host "orca.kitenet.net" $ props+	& standardSystem Unstable "amd64" [ "Main git-annex build box." ] 	& ipv4 "138.38.108.179"  	& Apt.unattendedUpgrades@@ -190,19 +195,19 @@  	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.standardAutoBuilder-		(System (Debian Unstable) "amd64") Nothing (Cron.Times "15 * * * *") "2h")+		Unstable "amd64" Nothing (Cron.Times "15 * * * *") "2h") 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.standardAutoBuilder-		(System (Debian Unstable) "i386") Nothing (Cron.Times "30 * * * *") "2h")+		Unstable "i386" Nothing (Cron.Times "30 * * * *") "2h") 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.stackAutoBuilder-		(System (Debian (Stable "jessie")) "i386") (Just "ancient") (Cron.Times "45 * * * *") "2h")+		(Stable "jessie") "i386" (Just "ancient") (Cron.Times "45 * * * *") "2h") 	& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer 		(Cron.Times "1 1 * * *") "3h")  honeybee :: Host-honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"-	[ "Arm git-annex build box." ]+honeybee = host "honeybee.kitenet.net" $ props+	& standardSystem Testing "armhf" [ "Arm git-annex build box." ]  	-- I have to travel to get console access, so no automatic 	-- upgrades, and try to be robust.@@ -229,14 +234,14 @@  	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.armAutoBuilder-			(System (Debian Unstable) "armel") Nothing Cron.Daily "22h")+			Unstable "armel" Nothing Cron.Daily "22h")  -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed -- with propellor. kite :: Host-kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"-	[ "Welcome to kite!" ]+kite = host "kite.kitenet.net" $ props+	& standardSystemUnhardened Testing "amd64" [ "Welcome to kite!" ] 	& ipv4 "66.228.36.95" 	& ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" 	& alias "kitenet.net"@@ -292,7 +297,6 @@ 	& alias "mail.kitenet.net" 	& JoeySites.kiteMailServer -	& JoeySites.kitenetHttps 	& JoeySites.legacyWebSites 	& File.ownerGroup "/srv/web" (User "joey") (Group "joey") 	& Apt.installed ["analog"]@@ -351,10 +355,11 @@ 		]  elephant :: Host-elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"-	[ "Storage, big data, and backups, omnomnom!"-	, "(Encrypt all data stored here.)"-	]+elephant = host "elephant.kitenet.net" $ props+	& standardSystem Unstable "amd64"+		[ "Storage, big data, and backups, omnomnom!"+		, "(Encrypt all data stored here.)"+		] 	& ipv4 "193.234.225.114" 	& Ssh.hostKeys hostContext 		[ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBANxXGWac0Yz58akI3UbLkphAa8VPDCGswTS0CT3D5xWyL9OeArISAi/OKRIvxA4c+9XnWtNXS7nYVFDJmzzg8v3ZMx543AxXK82kXCfvTOc/nAlVz9YKJAA+FmCloxpmOGrdiTx1k36FE+uQgorslGW/QTxnOcO03fDZej/ppJifAAAAFQCnenyJIw6iJB1+zuF/1TSLT8UAeQAAAIEA1WDrI8rKnxnh2rGaQ0nk+lOcVMLEr7AxParnZjgC4wt2mm/BmkF/feI1Fjft2z4D+V1W7MJHOqshliuproxhFUNGgX9fTbstFJf66p7h7OLAlwK8ZkpRk/uV3h5cIUPel6aCwjL5M2gN6/yq+gcCTXeHLq9OPyUTmlN77SBL71UAAACBAJJiCHWxPAGooe7Vv3W7EIBbsDyf7b2kDH3bsIlo+XFcKIN6jysBu4kn9utjFlrlPeHUDzGQHe+DmSqTUQQ0JPCRGcAcuJL8XUqhJi6A6ye51M9hVt51cJMXmERx9TjLOP/adkEuxpv3Fj20FxRUr1HOmvRvewSHrJ1GeA1bjbYL")@@ -412,7 +417,7 @@ 	& Ssh.listenPort (Port 80)  beaver :: Host-beaver = host "beaver.kitenet.net"+beaver = host "beaver.kitenet.net" $ props 	& ipv6 "2001:4830:1600:195::2" 	& Apt.serviceInstalledRunning "aiccu" 	& Apt.installed ["ssh"]@@ -425,7 +430,7 @@  -- Branchable is not completely deployed with propellor yet. pell :: Host-pell = host "pell.branchable.com"+pell = host "pell.branchable.com" $ props 	& alias "branchable.com" 	& ipv4 "66.228.46.55" 	& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"@@ -449,10 +454,10 @@ 	& Branchable.server hosts  iabak :: Host-iabak = host "iabak.archiveteam.org"+iabak = host "iabak.archiveteam.org" $ props 	& ipv4 "124.6.40.227" 	& Hostname.sane-	& os (System (Debian Testing) "amd64")+	& osDebian Testing "amd64" 	& Systemd.persistentJournal 	& Cron.runPropellor (Cron.Times "30 * * * *") 	& Apt.stdSourcesList `onChange` Apt.upgrade@@ -466,7 +471,7 @@ 	& Apt.installed ["vim", "screen", "tmux", "less", "emax-nox", "netcat"] 	& User.hasSomePassword (User "root") 	& propertyList "admin accounts"-		(map User.accountFor admins ++ map Sudo.enabledFor admins)+		(toProps $ map User.accountFor admins ++ map Sudo.enabledFor admins) 	& User.hasSomePassword (User "joey") 	& GitHome.installedFor (User "joey") 	& Ssh.authorizedKey (User "db48x") "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAAIAQDQ6urXcMDeyuFf4Ga7CuGezTShKnEMPHKJm7RQUtw3yXCPX5wnbvPS2+UFnHMzJvWOX5S5b/XpBpOusP0jLpxwOCEg4nA5b7uvWJ2VIChlMqopYMo+tDOYzK/Q74MZiNWi2hvf1tn3N9SnqOa7muBMKMENIX5KJdH8cJ/BaPqAP883gF8r2SwSZFvaB0xYCT/CIylC593n/+0+Lm07NUJIO8jil3n2SwXdVg6ib65FxZoO86M46wTghnB29GXqrzraOg+5DY1zzCWpIUtFwGr4DP0HqLVtmAkC7NI14l1M0oHE0UEbhoLx/a+mOIMD2DuzW3Rs3ZmHtGLj4PL/eBU8D33AqSeM0uR/0pEcoq6A3a8ixibj9MBYD2lMh+Doa2audxS1OLM//FeNccbm1zlvvde82PZtiO11P98uN+ja4A+CfgQU5s0z0wikc4gXNhWpgvz8DrOEJrjstwOoqkLg2PpIdHRw7dhpp3K1Pc+CGAptDwbKkxs4rzUgMbO9DKI7fPcXXgKHLLShMpmSA2vsQUMfuCp2cVrQJ+Vkbwo29N0Js5yU7L4NL4H854Nbk5uwWJCs/mjXtvTimN2va23HEecTpk44HDUjJ9NyevAfPcO9q1ZtgXFTQSMcdv1m10Fvmnaiy8biHnopL6MBo1VRITh5UFiJYfK4kpTTg2vSspii/FYkkYOAnnZtXZqMehP7OZjJ6HWJpsCVR2hxP3sKOoQu+kcADWa/4obdp+z7gY8iMMjd6kwuIWsNV8KsX+eVJ4UFpAi/L00ZjI2B9QLVCsOg6D1fT0698wEchwUROy5vZZJq0078BdAGnwC0WGLt+7OUgn3O2gUAkb9ffD0odbZSqq96NCelM6RaHA+AaIE4tjGL3lFkyOtb+IGPNACQ73/lmaRQd6Cgasq9cEo0g22Ew5NQi0CBuu1aLDk7ezu3SbU09eB9lcZ+8lFnl5K2eQFeVJStFJbJNfOvgKyOb7ePsrUFF5GJ2J/o1F60fRnG64HizZHxyFWkEOh+k3i8qO+whPa5MTQeYLYb6ysaTPrUwNRcSNNCcPEN8uYOh1dOFAtIYDcYA56BZ321yz0b5umj+pLsrFU+4wMjWxZi0inJzDS4dVegBVcRm0NP5u8VRosJQE9xdbt5K1I0khzhrEW1kowoTbhsZCaDHhL9LZo73Z1WIHvulvlF3RLZip5hhtQu3ZVkbdV5uts8AWaEWVnIu9z0GtQeeOuseZpT0u1/1xjVAOKIzuY3sB7FKOaipe8TDvmdiQf/ICySqqYaYhN6GOhiYccSleoX6yzhYuCvzTgAyWHIfW0t25ff1CM7Vn+Vo9cVplIer1pbwhZZy4QkROWTOE+3yuRlQ+o6op4hTGdAZhjKh9zkDW7rzqQECFrZrX/9mJhxYKjhpkk0X3dSipPt9SUHagc4igya+NgCygQkWBOQfr4uia0LcwDxy4Kchw7ZuypHuGVZkGhNHXS+9JdAHopnSqYwDMG/z1ys1vQihgER0b9g3TchvGF+nmHe2kbM1iuIYMNNlaZD1yGZ5qR7wr/8dw8r0NBEwzsUfak3BUPX7H6X0tGS96llwUxmvQD85WNNoef0uryuAtDEwWlfN1RmWysZDc57Rn4gZi0M5jXmQD23ZiYXYBcG849OeqNzlxONEFsForXO/29Ud4x/Hqa9tf+kJbqMRsaLFO+PXhHzgl6ZHLAljQDxrJ6keNnkqaYfqQ8wyRi1mKv4Ab57kde7mUsZhe7w93GaE9Lxfvu7d3pB+lXfI9NJCSITHreUP4JfmFW+p/eVg+r/1wbElNylGna4I4+qYObOUncGwFKYdFPdtU1XLDKXmywTEgbEh7iI9zX0xD3bPHQLMg+TTtXiU9dQm1x/0zRf9trwDsRDJCbG4/P4iQYkcVvYx2CCfi0JSHv8tWsLi3GJKJLXUxZyzfvY2lThPeYnnY/HFrPJCyJUN55QuRmfzbu8rHgWlcyOlVpKtz+7kn823kEQykiIYKIKrb0G6VBzuMtAk9XzJPv+Wu7suOGXHlVfCqPLk6RjHDm4kTYciW9VgxDts5Y+zwcAbrUeA4UuN/6KisWpivMrfDSIHUCeH/lHBtNkqKohdrUKJMEOx5X6r2dJbmoTFBDi5XtYu/5cBtiDMmupNB0S+pZ2JD5/RKtj6kgzTeE1q/OG4q/eq1O1rjf0vIS31luy27K/YHFIGE0D/CmuXE74Uyaxm27RnrKUxEBl84V70GaIF4F5On8pSThxxizigXTRTKiczc+A5Zi29mid+1EFeUAJOa/DuHJfpVNY4pYEmhPl/Bk66L8kzlbJz6Hg/LIiJIRcy3UKrbSxPFIDpXn33drBHgklMDlrIVDZDXF6cn0Ml71SabB4A3TM6TK+oWZoyvftPIhcWhVwAWQj7nFNAiMEl1z/29ovHrRooqQFozf7GDW8Mjiu7ChZP9zx2H8JB/AAEFuWMwGV4AHICYdS9lOl/v+cDhgsnXdeuKEuxHhYlRxuRxJk/f17Sm/5H85UIzlu85wi3q/DW2FTZnlw4iJLnL6FArUIMzuBOZyoEhh0SPR41Xc4kkucDhnENybTZSR/yDzb0P1B7qjZ4GqcSEFja/hm/LH1oKJzZg8MEqeUoKYCUdVv9ek4IUGUONtVs53V5SOwFWR/nVuDk2BENr7NadYYVtu6MjBwgjso7NuhoNxVwIEP3BW67OQ8bxfNBtJJQNJejAhgZiqJItI9ucAfjQ== db48x@anglachel"@@ -489,14 +494,16 @@  -- Simple web server, publishing the outside host's /var/www webserver :: Systemd.Container-webserver = standardStableContainer "webserver"+webserver = Systemd.debContainer "webserver" $ props+	& standardContainer (Stable "jessie") 	& Systemd.bind "/var/www" 	& Apache.installed  -- My own openid provider. Uses php, so containerized for security -- and administrative sanity. openidProvider :: Systemd.Container-openidProvider = standardStableContainer "openid-provider"+openidProvider = Systemd.debContainer "openid-provider" $ props+	& standardContainer (Stable "jessie") 	& alias hn 	& OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8081))   where@@ -504,7 +511,8 @@  -- Exhibit: kite's 90's website on port 1994. ancientKitenet :: Systemd.Container-ancientKitenet = standardStableContainer "ancient-kitenet"+ancientKitenet = Systemd.debContainer "ancient-kitenet" $ props+	& standardContainer (Stable "jessie") 	& alias hn 	& Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html" 		(Just "remotes/origin/old-kitenet.net")@@ -517,24 +525,27 @@ 	hn = "ancient.kitenet.net"  oldusenetShellBox :: Systemd.Container-oldusenetShellBox = standardStableContainer "oldusenet-shellbox"+oldusenetShellBox = Systemd.debContainer "oldusenet-shellbox" $ props+	& standardContainer (Stable "jessie") 	& alias "shell.olduse.net" 	& JoeySites.oldUseNetShellBox  kiteShellBox :: Systemd.Container-kiteShellBox = standardStableContainer "kiteshellbox"+kiteShellBox = Systemd.debContainer "kiteshellbox" $ props+	& standardContainer (Stable "jessie") 	& JoeySites.kiteShellBox  type Motd = [String]  -- This is my standard system setup.-standardSystem :: HostName -> DebianSuite -> Architecture -> Motd -> Host-standardSystem hn suite arch motd = standardSystemUnhardened hn suite arch motd-	& Ssh.noPasswords+standardSystem :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian)+standardSystem suite arch motd = +	standardSystemUnhardened suite arch motd+		`before` Ssh.noPasswords -standardSystemUnhardened :: HostName -> DebianSuite -> Architecture -> Motd -> Host-standardSystemUnhardened hn suite arch motd = host hn-	& os (System (Debian suite) arch)+standardSystemUnhardened :: DebianSuite -> Architecture -> Motd -> Property (HasInfo + Debian)+standardSystemUnhardened suite arch motd = propertyList "standard system" $ props+	& osDebian suite arch 	& Hostname.sane 	& Hostname.searchDomain 	& File.hasContent "/etc/motd" ("":motd++[""])@@ -555,32 +566,27 @@ 		`onChange` Apt.autoRemove  -- This is my standard container setup, Featuring automatic upgrades.-standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container-standardContainer name suite arch =-	Systemd.container name system (Chroot.debootstrapped mempty)-		& Apt.stdSourcesList `onChange` Apt.upgrade-		& Apt.unattendedUpgrades-		& Apt.cacheCleaned-  where-	system = System (Debian suite) arch--standardStableContainer :: Systemd.MachineName -> Systemd.Container-standardStableContainer name = standardContainer name (Stable "jessie") "amd64"+standardContainer :: DebianSuite -> Property (HasInfo + Debian)+standardContainer suite = propertyList "standard container" $ props+	& osDebian suite "amd64"+	& Apt.stdSourcesList `onChange` Apt.upgrade+	& Apt.unattendedUpgrades+	& Apt.cacheCleaned -myDnsSecondary :: Property HasInfo+myDnsSecondary :: Property (HasInfo + DebianLike) myDnsSecondary = propertyList "dns secondary for all my domains" $ props 	& Dns.secondary hosts "kitenet.net" 	& Dns.secondary hosts "joeyh.name" 	& Dns.secondary hosts "ikiwiki.info" 	& Dns.secondary hosts "olduse.net" -branchableSecondary :: RevertableProperty HasInfo+branchableSecondary :: RevertableProperty (HasInfo + DebianLike) DebianLike branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"  -- Currently using kite (ns4) as primary with secondaries -- elephant (ns3) and gandi. -- kite handles all mail.-myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty HasInfo+myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain 	(Dns.mkSOA "ns4.kitenet.net" 100) $ 	[ (RootDomain, NS $ AbsDomain "ns4.kitenet.net")@@ -594,20 +600,20 @@  monsters :: [Host]    -- Systems I don't manage with propellor, monsters =            -- but do want to track their public keys etc.-	[ host "usw-s002.rsync.net"+	[ host "usw-s002.rsync.net" $ props 		& Ssh.hostPubKey SshEd25519 "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB7yTEBGfQYdwG/oeL+U9XPMIh/dW7XNs9T+M79YIOrd"-	, host "github.com"+	, host "github.com" $ props 		& Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ=="-	, host "gitlab.com"+	, host "gitlab.com" $ props 		& Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY="-	, host "ns6.gandi.net"+	, host "ns6.gandi.net" $ props 		& ipv4 "217.70.177.40"-	, host "turtle.kitenet.net"+	, host "turtle.kitenet.net" $ props 		& ipv4 "67.223.19.96" 		& ipv6 "2001:4978:f:2d9::2"-	, host "mouse.kitenet.net"+	, host "mouse.kitenet.net" $ props 		& ipv6 "2001:4830:1600:492::2"-	, host "animx"+	, host "animx" $ props 		& ipv4 "76.7.162.101" 		& ipv4 "76.7.162.186" 	]

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.17.2+Version: 3.0.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -20,6 +20,7 @@   joeyconfig.hs   config.hs   contrib/post-merge-hook+  stack.yaml   debian/changelog   debian/README.Debian   debian/compat@@ -36,31 +37,39 @@  Executable propellor   Main-Is: wrapper.hs-  GHC-Options: -threaded -Wall -fno-warn-tabs+  GHC-Options: -threaded -Wall -fno-warn-tabs -O0+  Extensions: TypeOperators   Hs-Source-Dirs: src-  Build-Depends: +  Build-Depends:     -- propellor needs to support the ghc shipped in Debian stable     base >= 4.5, base < 5,     MissingH, directory, filepath, IfElse, process, bytestring, hslogger,     unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,-    time, mtl, transformers, exceptions (>= 0.6), stm, text+    time, mtl, transformers, exceptions (>= 0.6), stm, text,+    concurrent-output  Executable propellor-config   Main-Is: config.hs-  GHC-Options: -threaded -Wall -fno-warn-tabs+  GHC-Options: -threaded -Wall -fno-warn-tabs -O0+  Extensions: TypeOperators   Hs-Source-Dirs: src-  Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,-   IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers (>= 0.5), network, async, time, mtl, transformers,-   exceptions (>= 0.6), stm, text, unix+  Build-Depends: +    base >= 4.5, base < 5,+    MissingH, directory, filepath, IfElse, process, bytestring, hslogger,+    unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,+    time, mtl, transformers, exceptions (>= 0.6), stm, text,+    concurrent-output  Library-  GHC-Options: -Wall -fno-warn-tabs+  GHC-Options: -Wall -fno-warn-tabs -O0+  Extensions: TypeOperators   Hs-Source-Dirs: src-  Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,-   IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers (>= 0.5), network, async, time, mtl, transformers,-   exceptions (>= 0.6), stm, text, unix+  Build-Depends: +    base >= 4.5, base < 5,+    MissingH, directory, filepath, IfElse, process, bytestring, hslogger,+    unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,+    time, mtl, transformers, exceptions (>= 0.6), stm, text,+    concurrent-output    Exposed-Modules:     Propellor@@ -70,6 +79,7 @@     Propellor.Property.Aiccu     Propellor.Property.Apache     Propellor.Property.Apt+    Propellor.Property.Apt.PPA     Propellor.Property.Cmd     Propellor.Property.Concurrent     Propellor.Property.Conductor@@ -138,24 +148,30 @@     Propellor.PropAccum     Propellor.Utilities     Propellor.CmdLine+    Propellor.Container     Propellor.Info     Propellor.Message     Propellor.Debug+    Propellor.DotDir     Propellor.PrivData     Propellor.Engine+    Propellor.EnsureProperty     Propellor.Exception     Propellor.Types+    Propellor.Types.Core     Propellor.Types.Chroot+    Propellor.Types.CmdLine     Propellor.Types.Container     Propellor.Types.Docker     Propellor.Types.Dns     Propellor.Types.Empty     Propellor.Types.Info+    Propellor.Types.MetaTypes     Propellor.Types.OS     Propellor.Types.PrivData     Propellor.Types.Result     Propellor.Types.ResultCheck-    Propellor.Types.CmdLine+    Propellor.Types.Singletons     Propellor.Types.ZFS   Other-Modules:     Propellor.Bootstrap@@ -193,9 +209,6 @@     Utility.ThreadScheduler     Utility.Tmp     Utility.UserInfo-    System.Console.Concurrent-    System.Console.Concurrent.Internal-    System.Process.Concurrent  source-repository head   type: git

@@ -14,13 +14,14 @@ -- > main = defaultMain hosts -- >  -- > hosts :: [Host]--- > hosts =--- >   [ host "example.com"+-- > hosts = [example]+-- > +-- > example :: Host+-- > example = host "example.com" $ props -- >     & Apt.installed ["mydaemon"] -- >     & "/etc/mydaemon.conf" `File.containsLine` "secure=1" -- >       `onChange` cmdProperty "service" ["mydaemon", "restart"] -- >     ! Apt.installed ["unwantedpackage"]--- >   ] -- -- See config.hs for a more complete example, and clone Propellor's -- git repository for a deployable system using Propellor:@@ -38,7 +39,6 @@ 	, (&) 	, (!) 	-- * Propertries-	, describe 	-- | Properties are often combined together in your propellor 	-- configuration. For example: 	--@@ -47,6 +47,7 @@ 	, requires 	, before 	, onChange+	, describe 	, module Propellor.Property 	-- | Everything you need to build your own properties, 	-- and useful property combinators

@@ -7,6 +7,7 @@  import Propellor.Base import Propellor.Types.Info+import Propellor.Git.Config  import System.Posix.Files import Data.List@@ -71,7 +72,7 @@ 		, "cabal install --only-dependencies" 		] -	aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get --no-upgrade --no-install-recommends -y install " ++ p+	aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p 	pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p  	-- This is the same deps listed in debian/control.@@ -91,6 +92,7 @@ 		, "libghc-exceptions-dev" 		, "libghc-stm-dev" 		, "libghc-text-dev"+		, "libghc-concurrent-output-dev" 		, "make" 		] 	fbsddeps =@@ -109,6 +111,7 @@ 		, "hs-exceptions" 		, "hs-stm" 		, "hs-text"+		, "hs-concurrent-output" 		, "gmake" 		] @@ -126,27 +129,33 @@ 	use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi" 	apt =  		[ "apt-get update"-		, "DEBIAN_FRONTEND=noninteractive apt-get --no-install-recommends --no-upgrade -y install git"+		, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" 		]  buildPropellor :: Maybe Host -> IO () buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $ 	errorMessage "Propellor build failed!"   where-	msys = case fmap (getInfo . hostInfo) mh of+	msys = case fmap (fromInfo . hostInfo) mh of 		Just (InfoVal sys) -> Just sys 		_ -> Nothing --- Build propellor using cabal, and symlink propellor to where cabal--- leaves the built binary.---+-- Build propellor using cabal or stack, and symlink propellor to the+-- built binary.+build :: Maybe System -> IO Bool+build msys = catchBoolIO $ do+	bs <- getGitConfigValue "propellor.buildsystem"+	case bs of+		Just "stack" -> stackBuild msys+		_ -> cabalBuild msys+ -- For speed, only runs cabal configure when it's not been run before. -- If the build fails cabal may need to have configure re-run. -- -- If the cabal configure fails, and a System is provided, installs -- dependencies and retries.-build :: Maybe System -> IO Bool-build msys = catchBoolIO $ do+cabalBuild :: Maybe System -> IO Bool+cabalBuild msys = do 	make "dist/setup-config" ["propellor.cabal"] cabal_configure 	unlessM cabal_build $ 		unlessM (cabal_configure <&&> cabal_build) $@@ -161,14 +170,11 @@ 	unlessM (boolSystem "cp" [Param "-af", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $ 		error "cp of binary failed" 	rename (tmpfor safetycopy) safetycopy-	createSymbolicLink safetycopy (tmpfor dest)-	rename (tmpfor dest) dest+	symlinkPropellorBin safetycopy 	return True   where-	dest = "propellor" 	cabalbuiltbin = "dist/build/propellor-config/propellor-config" 	safetycopy = cabalbuiltbin ++ ".built"-	tmpfor f = f ++ ".propellortmp" 	cabal_configure = ifM (cabal ["configure"]) 		( return True 		, case msys of@@ -179,6 +185,35 @@ 		) 	cabal_build = cabal ["build", "propellor-config"] +stackBuild :: Maybe System -> IO Bool+stackBuild _msys = do+	createDirectoryIfMissing True builddest+	ifM (stack buildparams)+		( do+			symlinkPropellorBin (builddest </> "propellor-config")+			return True+		, return False+		)+  where+ 	builddest = ".built"+	buildparams =+		[ "--local-bin-path", builddest+		, "build"+		, ":propellor-config" -- only build config program+		, "--copy-bins"+		]++-- Atomic symlink creation/update.+symlinkPropellorBin :: FilePath -> IO ()+symlinkPropellorBin bin = do+	createSymbolicLink bin (tmpfor dest)+	rename (tmpfor dest) dest+  where+	dest = "propellor"++tmpfor :: FilePath -> FilePath+tmpfor f = f ++ ".propellortmp"+ make :: FilePath -> [FilePath] -> IO Bool -> IO () make dest srcs builder = do 	dt <- getmtime dest@@ -191,3 +226,6 @@  cabal :: [String] -> IO Bool cabal = boolSystem "cabal" . map Param++stack :: [String] -> IO Bool+stack = boolSystem "stack" . map Param

@@ -16,6 +16,7 @@ import Propellor.Bootstrap import Propellor.Spin import Propellor.Types.CmdLine+import Propellor.DotDir (interactiveInit) import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim@@ -23,6 +24,7 @@ usage :: Handle -> IO () usage h = hPutStrLn h $ unlines 	[ "Usage:"+	, "  propellor --init" 	, "  propellor" 	, "  propellor hostname" 	, "  propellor --spin targethost [--via relayhost]"@@ -69,6 +71,7 @@ 	go ("--serialized":s:[]) = serialized Serialized s 	go ("--continue":s:[]) = serialized Continue s 	go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)+	go ("--init":_) = return Init 	go ("--run":h:[]) = go [h] 	go (h:[]) 		| "--" `isPrefixOf` h = usageError [h]@@ -130,6 +133,7 @@ 		fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn)) 	-- When continuing after a rebuild, don't want to rebuild again. 	go _ (Continue cmdline) = go NoRebuild cmdline+	go _ Init = interactiveInit  	withhost :: HostName -> (Host -> IO ()) -> IO () 	withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)@@ -149,6 +153,9 @@ -- Builds propellor (when allowed) and if it looks like a new binary, -- re-execs it to continue. -- Otherwise, runs the IO action to continue.+--+-- The Host should only be provided when dependencies should be installed+-- as needed to build propellor. buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () buildFirst h CanRebuild cmdline next = do 	oldtime <- getmtime

@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds, TypeFamilies #-}++module Propellor.Container where++import Propellor.Types+import Propellor.Types.Core+import Propellor.Types.MetaTypes+import Propellor.Types.Info+import Propellor.Info+import Propellor.PrivData+import Propellor.PropAccum++class IsContainer c where+	containerProperties :: c -> [ChildProperty]+	containerInfo :: c -> Info+	setContainerProperties :: c -> [ChildProperty] -> c++instance IsContainer Host where+	containerProperties = hostProperties+	containerInfo = hostInfo+	setContainerProperties h ps = host (hostName h) (Props ps)++-- | Note that the metatype of a container's properties is not retained,+-- so this defaults to UnixLike. So, using this with setContainerProps can+-- add properties to a container that conflict with properties already in it.+-- Use caution when using this; only add properties that do not have+-- restricted targets.+containerProps :: IsContainer c => c -> Props UnixLike+containerProps = Props . containerProperties++setContainerProps :: IsContainer c => c -> Props metatypes -> c+setContainerProps c (Props ps) = setContainerProperties c ps++-- | Adjust the provided Property, adding to its+-- propertyChidren the properties of the provided container.+-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propagated out to the Property.+--+-- Any PrivInfo that uses HostContext is adjusted to use the name+-- of the container as its context.+propagateContainer+	::+		-- Since the children being added probably have info,+		-- require the Property's metatypes to have info.+		( IncludesInfo metatypes ~ 'True+		, IsContainer c+		)+	=> String+	-> c+	-> Property metatypes+	-> Property metatypes+propagateContainer containername c prop = prop+	`addChildren` map convert (containerProperties c)+  where+	convert p = +		let n = property (getDesc p) (getSatisfy p) :: Property UnixLike+		    n' = n+		    	`setInfoProperty` mapInfo (forceHostContext containername)+				(propagatableInfo (getInfo p))+		   	`addChildren` map convert (getChildren p)+		in toChildProperty n'

@@ -0,0 +1,393 @@+module Propellor.DotDir where++import Propellor.Message+import Propellor.Bootstrap+import Propellor.Git+import Propellor.Gpg+import Propellor.Types.Result+import Utility.UserInfo+import Utility.Monad+import Utility.Process+import Utility.SafeCommand+import Utility.Exception+import Utility.Path+-- This module is autogenerated by the build system.+import qualified Paths_propellor as Package++import Data.Char+import Data.List+import Data.Version+import Control.Monad+import Control.Monad.IfElse+import System.Directory+import System.FilePath+import System.Posix.Directory+import System.IO+import System.Console.Concurrent+import Control.Applicative+import Prelude++distdir :: FilePath+distdir = "/usr/src/propellor"++-- A distribution may include a bundle of propellor's git repository here.+-- If not, it will be pulled from the network when needed.+distrepo :: FilePath+distrepo = distdir </> "propellor.git"++-- File containing the head rev of the distrepo.+disthead :: FilePath+disthead = distdir </> "head"++upstreambranch :: String+upstreambranch = "upstream/master"++-- Using the github mirror of the main propellor repo because+-- it is accessible over https for better security.+netrepo :: String+netrepo = "https://github.com/joeyh/propellor.git"++dotPropellor :: IO FilePath+dotPropellor = do+	home <- myHomeDir+	return (home </> ".propellor")++-- Detect if propellor was built using stack. This is somewhat of a hack.+buildSystem :: IO String+buildSystem = do+	d <- Package.getLibDir+	return $ if "stack-work" `isInfixOf` d then "stack" else "cabal"++interactiveInit :: IO ()+interactiveInit = ifM (doesDirectoryExist =<< dotPropellor)+	( error "~/.propellor/ already exists, not doing anything"+	, do+		welcomeBanner+		setup+	)++say :: String -> IO ()+say = outputConcurrent++sayLn :: String -> IO ()+sayLn s = say (s ++ "\n")++welcomeBanner :: IO ()+welcomeBanner = say $ unlines $ map prettify+	[ ""+	, ""+	, "                                 _         ______`|                     ,-.__"+	, " .---------------------------  /   ~___-=O`/|O`/__|                    (____.'"+	, "  - Welcome to              -- ~          / | /    )        _.-'-._"+	, "  -            Propellor!   --  `/-==__ _/__|/__=-|        (       ~_"+	, " `---------------------------   *             ~ | |         '--------'"+	, "                                            (o)  `"+	, ""+	, ""+	]+  where+	prettify = map (replace '~' '\\')+	replace x y c+		| c == x = y+		| otherwise = c++prompt :: String -> [(String, IO ())] -> IO ()+prompt p cs = do+	say (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ")+	flushConcurrentOutput+	hFlush stdout+	r <- map toLower <$> getLine+	if null r+		then snd (head cs) -- default to first choice on return+		else case filter (\(s, _) -> map toLower s == r) cs of+			[(_, a)] -> a+			_ -> do+				sayLn "Not a valid choice, try again.. (Or ctrl-c to quit)"+				prompt p cs++section :: IO ()+section = do+	sayLn ""+	sayLn "------------------------------------------------------------------------------"+	sayLn ""++setup :: IO ()+setup = do+	sayLn "Propellor's configuration file is ~/.propellor/config.hs"+	sayLn ""+	sayLn "Lets get you started with a simple config that you can adapt"+	sayLn "to your needs. You can start with:"+	sayLn "   A: A clone of propellor's git repository    (most flexible)"+	sayLn "   B: The bare minimum files to use propellor  (most simple)"+	prompt "Which would you prefer?"+		[ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone)+		, ("B", void $ actionMessage "Creating minimal config" minimalConfig)+		]+	changeWorkingDirectory =<< dotPropellor++	section+	sayLn "Let's try building the propellor configuration, to make sure it will work..."+	sayLn ""+	b <- buildSystem+	void $ boolSystem "git"+		[ Param "config"+		, Param "propellor.buildsystem"+		, Param b+		]+	buildPropellor Nothing+	sayLn ""+	sayLn "Great! Propellor is bootstrapped."+	+	section+	sayLn "Propellor can use gpg to encrypt private data about the systems it manages,"+	sayLn "and to sign git commits."+	gpg <- getGpgBin+	ifM (inPath gpg)+		( setupGpgKey+		, do+			sayLn "You don't seem to have gpg installed, so skipping setting it up."+			explainManualSetupGpgKey+		)++	section+	sayLn "Everything is set up ..."+	sayLn "Your next step is to edit ~/.propellor/config.hs"+	sayLn "and run propellor again to try it out."+	sayLn ""+	sayLn "For docs, see https://propellor.branchable.com/"+	sayLn "Enjoy propellor!"++explainManualSetupGpgKey :: IO ()+explainManualSetupGpgKey = do+	sayLn "Propellor can still be used without gpg, but it won't be able to"+	sayLn "manage private data. You can set this up later:"+	sayLn " 1. gpg --gen-key"+	sayLn " 2. propellor --add-key (pass it the key ID generated in step 1)"++setupGpgKey :: IO ()+setupGpgKey = do+	ks <- listSecretKeys+	sayLn ""+	case ks of+		[] -> makeGpgKey+		[(k, d)] -> do+			sayLn $ "You have one gpg key: " ++ desckey k d+			prompt "Should propellor use that key?"+				[ ("Y", propellorAddKey k)+				, ("N", sayLn $ "Skipping gpg setup. If you change your mind, run: propellor --add-key " ++ k)+				]+		_ -> do+			let nks = zip ks (map show ([1..] :: [Integer]))+			sayLn "I see you have several gpg keys:"+			forM_ nks $ \((k, d), n) ->+				sayLn $ "   " ++ n ++ "   " ++ desckey k d+			prompt "Which of your gpg keys should propellor use?"+				(map (\((k, _), n) -> (n, propellorAddKey k)) nks)+  where+	desckey k d = d ++ "  (keyid " ++ k ++ ")"++makeGpgKey :: IO ()+makeGpgKey = do+	sayLn "You seem to not have any gpg secret keys."+	prompt "Would you like to create one now?"+		[("Y", rungpg), ("N", nope)]+  where+	nope = do+		sayLn "No problem."+		explainManualSetupGpgKey+	rungpg = do+		sayLn "Running gpg --gen-key ..."+		gpg <- getGpgBin+		void $ boolSystem gpg [Param "--gen-key"]+		ks <- listSecretKeys+		case ks of+			[] -> do+				sayLn "Hmm, gpg seemed to not set up a secret key."+				prompt "Want to try running gpg again?"+					[("Y", rungpg), ("N", nope)]+			((k, _):_) -> propellorAddKey k++propellorAddKey :: String -> IO ()+propellorAddKey keyid = do+	sayLn ""+	sayLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid+	d <- dotPropellor+	unlessM (boolSystem (d </> "propellor") [Param "--add-key", Param keyid]) $ do+		sayLn "Oops, that didn't work! You can retry the same command later."+		sayLn "Continuing onward ..."++minimalConfig :: IO Result+minimalConfig = do+	d <- dotPropellor+	createDirectoryIfMissing True d+	changeWorkingDirectory d+	void $ boolSystem "git" [Param "init"]+	addfile "config.cabal" cabalcontent+	addfile "config.hs" configcontent+	addfile "stack.yaml" stackcontent+	return MadeChange+  where+	addfile f content = do+		writeFile f (unlines content)+		void $ boolSystem "git" [Param "add" , File f]+	cabalcontent =+		[ "-- This is a cabal file to use to build your propellor configuration."+		, ""+		, "Name: config"+		, "Cabal-Version: >= 1.6"+		, "Build-Type: Simple"+		, "Version: 0"+		, ""+		, "Executable propellor-config"+		, "  Main-Is: config.hs"+		, "  GHC-Options: -threaded -Wall -fno-warn-tabs -O0"+		, "  Extensions: TypeOperators"+		, "  Build-Depends: propellor >= 3.0, base >= 3"+		]+	configcontent = +		[ "-- This is the main configuration file for Propellor, and is used to build"+		, "-- the propellor program.    https://propellor.branchable.com/"+		, ""+		, "import Propellor"+		, "import qualified Propellor.Property.File as File"+		, "import qualified Propellor.Property.Apt as Apt"+		, "import qualified Propellor.Property.Cron as Cron"+		, "import qualified Propellor.Property.User as User"+		, ""+		, "main :: IO ()"+		, "main = defaultMain hosts"+		, ""+		, "-- The hosts propellor knows about."+		, "hosts :: [Host]"+		, "hosts ="+		, "        [ mybox"+		, "        ]"+		, ""+		, "-- An example host."+		, "mybox :: Host"+		, "mybox = host \"mybox.example.com\" $ props"+		, "        & osDebian Unstable \"amd64\""+		, "        & Apt.stdSourcesList"+		, "        & Apt.unattendedUpgrades"+		, "        & Apt.installed [\"etckeeper\"]"+		, "        & Apt.installed [\"ssh\"]"+		, "        & User.hasSomePassword (User \"root\")"+		, "        & File.dirExists \"/var/www\""+		, "        & Cron.runPropellor (Cron.Times \"30 * * * *\")"+		, ""+		]+	stackcontent =+		-- This should be the same resolver version in propellor's+		-- own stack.yaml+		[ "resolver: lts-5.10"+		, "packages:"+		, "- '.'"+		, "extra-deps:"+		, "- propellor-" ++ showVersion Package.version+		]++fullClone :: IO Result+fullClone = do+	d <- dotPropellor+	let enterdotpropellor = changeWorkingDirectory d >> return True+	ok <- ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)+		( allM id+			[ boolSystem "git" [Param "clone", File distrepo, File d]+			, fetchUpstreamBranch distrepo+			, enterdotpropellor+			, boolSystem "git" [Param "remote", Param "rm", Param "origin"]+			]+		, allM id+			[ boolSystem "git" [Param "clone", Param netrepo, File d]+			, enterdotpropellor+			-- Rename origin to upstream and avoid+			-- git push to that read-only repo.+			, boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"]+			, boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"]+			]+		)+	return (toResult ok)++fetchUpstreamBranch :: FilePath -> IO Bool+fetchUpstreamBranch repo = do+	changeWorkingDirectory =<< dotPropellor+	boolSystem "git"+		[ Param "fetch"+		, File repo+		, Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch)+		, Param "--quiet"+		]++checkRepoUpToDate :: IO ()+checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do+	headrev <- takeWhile (/= '\n') <$> readFile disthead+	changeWorkingDirectory =<< dotPropellor+	headknown <- catchMaybeIO $ +		withQuietOutput createProcessSuccess $+			proc "git" ["log", headrev]+	if (headknown == Nothing)+		then setupUpstreamMaster headrev+		else do+			theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef+			when (theirhead /= headrev) $ do+				merged <- not . null <$>+					readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"]+				unless merged $+					warnoutofdate True+  where+	gitbundleavail = doesFileExist disthead+	dotpropellorpopulated = do+		d <- dotPropellor+		doesFileExist (d </> "propellor.cabal")++-- Makes upstream/master in dotPropellor be a usefully mergeable branch.+--+-- We cannot just use origin/master, because in the case of a distrepo,+-- it only contains 1 commit. So, trying to merge with it will result+-- in lots of merge conflicts, since git cannot find a common parent+-- commit.+--+-- Instead, the upstream/master branch is created by taking the+-- upstream/master branch (which must be an old version of propellor,+-- as distributed), and diffing from it to the current origin/master,+-- and committing the result. This is done in a temporary clone of the+-- repository, giving it a new master branch. That new branch is fetched+-- into the user's repository, as if fetching from a upstream remote,+-- yielding a new upstream/master branch.+setupUpstreamMaster :: String -> IO ()+setupUpstreamMaster newref = do+	changeWorkingDirectory =<< dotPropellor+	go =<< catchMaybeIO getoldrev+  where+	go Nothing = warnoutofdate False+	go (Just oldref) = do+		let tmprepo = ".git/propellordisttmp"+		let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo+		cleantmprepo+		git ["clone", "--quiet", ".", tmprepo]+	+		changeWorkingDirectory tmprepo+		git ["fetch", distrepo, "--quiet"]+		git ["reset", "--hard", oldref, "--quiet"]+		git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"]+	+		void $ fetchUpstreamBranch tmprepo+		cleantmprepo+		warnoutofdate True++	getoldrev = takeWhile (/= '\n')+		<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]+	+	git = run "git"+	run cmd ps = unlessM (boolSystem cmd (map Param ps)) $+		error $ "Failed to run " ++ cmd ++ " " ++ show ps++warnoutofdate :: Bool -> IO ()+warnoutofdate havebranch = do+	warningMessage ("** Your ~/.propellor/ is out of date..")+	let also s = hPutStrLn stderr ("   " ++ s)+	also ("A newer upstream version is available in " ++ distrepo)+	if havebranch+		then also ("To merge it, run: git merge " ++ upstreambranch)+		else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.")+	also ""

@@ -1,11 +1,10 @@ {-# LANGUAGE PackageImports #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}  module Propellor.Engine ( 	mainProperties, 	runPropellor,-	ensureProperty,-	ensureProperties,+	ensureChildProperties, 	fromHost, 	fromHost', 	onlyProcess,@@ -23,24 +22,26 @@ import Prelude  import Propellor.Types+import Propellor.Types.MetaTypes+import Propellor.Types.Core import Propellor.Message import Propellor.Exception import Propellor.Info-import Propellor.Property import Utility.Exception  -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. mainProperties :: Host -> IO () mainProperties host = do-	ret <- runPropellor host $-		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]+	ret <- runPropellor host $ ensureChildProperties [toChildProperty overall] 	messagesDone 	case ret of 		FailedChange -> exitWith (ExitFailure 1) 		_ -> exitWith ExitSuccess   where-	ps = map ignoreInfo $ hostProperties host+	overall :: Property (MetaTypes '[])+	overall = property "overall" $+		ensureChildProperties (hostProperties host)  -- | Runs a Propellor action with the specified host. --@@ -58,14 +59,14 @@ 	(ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host () 	return ret --- | Ensures a list of Properties, with a display of each as it runs.-ensureProperties :: [Property NoInfo] -> Propellor Result-ensureProperties ps = ensure ps NoChange+-- | Ensures the child properties, with a display of each as it runs.+ensureChildProperties :: [ChildProperty] -> Propellor Result+ensureChildProperties ps = ensure ps NoChange   where 	ensure [] rs = return rs 	ensure (p:ls) rs = do 		hn <- asks hostName-		r <- actionMessageOn hn (propertyDesc p) (ensureProperty p)+		r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p) 		ensure ls (r <> rs)  -- | Lifts an action into the context of a different host.

@@ -0,0 +1,70 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Propellor.EnsureProperty+	( ensureProperty+	, property'+	, OuterMetaTypesWitness(..)+	) where++import Propellor.Types+import Propellor.Types.Core+import Propellor.Types.MetaTypes+import Propellor.Exception++import Data.Monoid+import Prelude++-- | For when code running in the Propellor monad needs to ensure a+-- Property.+--+-- Use `property'` to get the `OuterMetaTypesWithness`. For example:+--+-- > foo = Property Debian+-- > foo = property' $ \w -> do+-- > 	ensureProperty w (aptInstall "foo")+--+-- The type checker will prevent using ensureProperty with a property+-- that does not support the target OSes needed by the OuterMetaTypesWitness.+-- In the example above, aptInstall must support Debian, since foo+-- is supposed to support Debian.+--+-- The type checker will also prevent using ensureProperty with a property+-- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated+-- with the property to be lost.+ensureProperty+	::+		( Cannot_ensureProperty_WithInfo inner ~ 'True+		, (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine+		)+	=> OuterMetaTypesWitness outer+	-> Property (MetaTypes inner)+	-> Propellor Result+ensureProperty _ = catchPropellor . getSatisfy++-- The name of this was chosen to make type errors a more understandable.+type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool+type instance Cannot_ensureProperty_WithInfo '[] = 'True+type instance Cannot_ensureProperty_WithInfo (t ': ts) =+	Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts++-- | Constructs a property, like `property`, but provides its+-- `OuterMetaTypesWitness`.+property'+	:: SingI metatypes+	=> Desc+	-> (OuterMetaTypesWitness metatypes -> Propellor Result)+	-> Property (MetaTypes metatypes)+property' d a =+	let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty+	in p++-- | Used to provide the metatypes of a Property to calls to +-- 'ensureProperty` within it.+newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes)++outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l+outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes

@@ -32,14 +32,21 @@ -- Lists the keys in propellor's keyring. listPubKeys :: IO [KeyId] listPubKeys = do-	gpgbin <- getGpgBin 	keyring <- privDataKeyring-	parse . lines <$> readProcess gpgbin (listopts keyring)+	map fst <$> listKeys ("--list-public-keys" : useKeyringOpts keyring)++listSecretKeys :: IO [(KeyId, String)]+listSecretKeys = listKeys ["--list-secret-keys"]++listKeys :: [String] -> IO [(KeyId, String)]+listKeys ps = do+	gpgbin <- getGpgBin+	parse . lines <$> readProcess gpgbin listopts   where-	listopts keyring = useKeyringOpts keyring ++-		["--with-colons", "--list-public-keys"]+	listopts = ps ++ ["--with-colons"] 	parse = mapMaybe (keyIdField . split ":")-	keyIdField ("pub":_:_:_:f:_) = Just f+	keyIdField (t:_:_:_:f:_:_:_:_:n:_)+		| t == "pub" || t == "sec" = Just (f, n) 	keyIdField _ = Nothing  useKeyringOpts :: FilePath -> [String]

@@ -1,9 +1,30 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} -module Propellor.Info where+module Propellor.Info (+	osDebian,+	osBuntish,+	osFreeBSD,+	setInfoProperty,+	addInfoProperty,+	pureInfoProperty,+	pureInfoProperty',+	askInfo,+	getOS,+	ipv4,+	ipv6,+	alias,+	addDNS,+	hostMap,+	aliasMap,+	findHost,+	findHostNoAlias,+	getAddresses,+	hostAddresses,+) where  import Propellor.Types import Propellor.Types.Info+import Propellor.Types.MetaTypes  import "mtl" Control.Monad.Reader import qualified Data.Set as S@@ -13,21 +34,67 @@ import Control.Applicative import Prelude -pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo-pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v)+-- | Adds info to a Property.+--+-- The new Property will include HasInfo in its metatypes.+setInfoProperty+	:: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')+	=> Property metatypes+	-> Info+	-> Property (MetaTypes metatypes')+setInfoProperty (Property _ d a oldi c) newi =+	Property sing d a (oldi <> newi) c -pureInfoProperty' :: Desc -> Info -> Property HasInfo-pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty+-- | Adds more info to a Property that already HasInfo.+addInfoProperty+	:: (IncludesInfo metatypes ~ 'True)+	=> Property metatypes+	-> Info+	-> Property metatypes+addInfoProperty (Property t d a oldi c) newi =+	Property t d a (oldi <> newi) c +-- | Makes a property that does nothing but set some `Info`.+pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)+pureInfoProperty desc v = pureInfoProperty' desc (toInfo v)++pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)+pureInfoProperty' desc i = setInfoProperty p i+  where+	p :: Property UnixLike+	p = property ("has " ++ desc) (return NoChange)+ -- | Gets a value from the host's Info. askInfo :: (IsInfo v) => Propellor v-askInfo = asks (getInfo . hostInfo)+askInfo = asks (fromInfo . hostInfo) --- | Specifies the operating system of a host.+-- | Specifies that a host's operating system is Debian,+-- and further indicates the suite and architecture.+-- +-- This provides info for other Properties, so they can act+-- conditionally on the details of the OS. ----- This only provides info for other Properties, so they can act--- conditionally on the os.-os :: System -> Property HasInfo+-- It also lets the type checker know that all the properties of the+-- host must support Debian.+--+-- > & osDebian (Stable "jessie") "amd64"+osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)+osDebian suite arch = tightenTargets $ os (System (Debian suite) arch)++-- | Specifies that a host's operating system is a well-known Debian+-- derivative founded by a space tourist.+--+-- (The actual name of this distribution is not used in Propellor per+-- <http://joeyh.name/blog/entry/trademark_nonsense/>)+osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish)+osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)++-- | Specifies that a host's operating system is FreeBSD+-- and further indicates the release and architecture.+osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)+osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)++os :: System -> Property (HasInfo + UnixLike) os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)  --  Gets the operating system of a host, if it has been specified.@@ -43,11 +110,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 HasInfo+ipv4 :: String -> Property (HasInfo + UnixLike) ipv4 = addDNS . Address . IPv4  -- | Indicate that a host has an AAAA record in the DNS.-ipv6 :: String -> Property HasInfo+ipv6 :: String -> Property (HasInfo + UnixLike) ipv6 = addDNS . Address . IPv6  -- | Indicates another name for the host in the DNS.@@ -56,14 +123,14 @@ -- to use their address, rather than using a CNAME. This avoids various -- problems with CNAMEs, and also means that when multiple hosts have the -- same alias, a DNS round-robin is automatically set up.-alias :: Domain -> Property HasInfo+alias :: Domain -> Property (HasInfo + UnixLike) alias d = pureInfoProperty' ("alias " ++ d) $ mempty 	`addInfo` toAliasesInfo [d] 	-- A CNAME is added here, but the DNS setup code converts it to an 	-- IP address when that makes sense. 	`addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d) -addDNS :: Record -> Property HasInfo+addDNS :: Record -> Property (HasInfo + UnixLike) addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))   where 	rdesc (CNAME d) = unwords ["alias", ddesc d]@@ -86,7 +153,7 @@  aliasMap :: [Host] -> M.Map HostName Host aliasMap = M.fromList . concat .-	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h)+	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h)  findHost :: [Host] -> HostName -> Maybe Host findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)@@ -98,10 +165,7 @@ findAlias l hn = M.lookup hn (aliasMap l)  getAddresses :: Info -> [IPAddr]-getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo+getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo  hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)--addHostInfo ::IsInfo v => Host -> v -> Host-addHostInfo h v = h { hostInfo = addInfo (hostInfo h) v }

@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}  module Propellor.PrivData ( 	withPrivData,@@ -40,6 +42,7 @@  import Propellor.Types import Propellor.Types.PrivData+import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.Message import Propellor.Info@@ -75,29 +78,41 @@ -- being used, which is necessary to ensure that the privdata is sent to -- the remote host by propellor. withPrivData-	:: (IsContext c, IsPrivDataSource s, IsProp (Property i))+	::+		( IsContext c+		, IsPrivDataSource s+		, IncludesInfo metatypes ~ 'True+		) 	=> s 	-> c-	-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)-	-> Property HasInfo+	-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property metatypes)+	-> Property metatypes withPrivData s = withPrivData' snd [s]  -- Like withPrivData, but here any one of a list of PrivDataFields can be used. withSomePrivData-	:: (IsContext c, IsPrivDataSource s, IsProp (Property i))+	::+		( IsContext c+		, IsPrivDataSource s+		, IncludesInfo metatypes ~ 'True+		) 	=> [s] 	-> c-	-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)-	-> Property HasInfo+	-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property metatypes)+	-> Property metatypes withSomePrivData = withPrivData' id  withPrivData' -	:: (IsContext c, IsPrivDataSource s, IsProp (Property i))+	::+		( IsContext c+		, IsPrivDataSource s+		, IncludesInfo metatypes ~ 'True+		) 	=> ((PrivDataField, PrivData) -> v) 	-> [s] 	-> c-	-> (((v -> Propellor Result) -> Propellor Result) -> Property i)-	-> Property HasInfo+	-> (((v -> Propellor Result) -> Propellor Result) -> Property metatypes)+	-> Property metatypes withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> 	maybe missing (a . feed) =<< getM get fieldlist   where@@ -112,11 +127,7 @@ 			"Fix this by running:" : 			showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) 		return FailedChange-	addinfo p = infoProperty-		(propertyDesc p)-		(propertySatisfy p)-		(propertyInfo p `addInfo` privset)-		(propertyChildren p)+	addinfo p = p `addInfoProperty` (toInfo privset) 	privset = PrivInfo $ S.fromList $ 		map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist 	fieldnames = map show fieldlist@@ -132,7 +143,7 @@ 		, Just "" 		] -addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo+addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property (HasInfo + UnixLike) addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v))  {- Gets the requested field's value, in the specified context if it's@@ -150,7 +161,7 @@ filterPrivData host = M.filterWithKey (\k _v -> S.member k used)   where 	used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $-		fromPrivInfo $ getInfo $ hostInfo host+		fromPrivInfo $ fromInfo $ hostInfo host  getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData getPrivData field context m = do@@ -234,7 +245,7 @@ mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a mkPrivDataMap host mkv = M.fromList $ 	map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d))-		(S.toList $ fromPrivInfo $ getInfo $ hostInfo host)+		(S.toList $ fromPrivInfo $ fromInfo $ hostInfo host)  setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () setPrivDataTo field context (PrivData value) = do

@@ -1,88 +1,86 @@-{-# LANGUAGE PackageImports, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}  module Propellor.PropAccum 	( host-	, PropAccum(..)+	, Props(..)+	, props 	, (&) 	, (&^) 	, (!)-	, propagateContainer 	) where -import Data.Monoid- import Propellor.Types+import Propellor.Types.MetaTypes+import Propellor.Types.Core import Propellor.Property-import Propellor.Types.Info-import Propellor.PrivData --- | Starts accumulating the properties of a Host.+import Data.Monoid+import Prelude++-- | Defines a host and its properties. ----- > host "example.com"+-- > host "example.com" $ props -- > 	& someproperty -- > 	! oldproperty -- > 	& otherproperty-host :: HostName -> Host-host hn = Host hn [] mempty+host :: HostName -> Props metatypes -> Host+host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Something that can accumulate properties.-class PropAccum h where-	-- | Adds a property.-	addProp :: IsProp p => h -> p -> h+-- | Start accumulating a list of properties.+--+-- Properties can be added to it using `(&)` etc.+props :: Props UnixLike+props = Props [] -	-- | Like addProp, but adds the property at the front of the list.-	addPropFront :: IsProp p => h -> p -> h+infixl 1 &+infixl 1 &^+infixl 1 ! -	getProperties :: h -> [Property HasInfo]+type family GetMetaTypes x+type instance GetMetaTypes (Property (MetaTypes t)) = MetaTypes t+type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t --- | Adds a property to a `Host` or other `PropAccum`+-- | Adds a property to a Props. -- -- Can add Properties and RevertableProperties-(&) :: (PropAccum h, IsProp p) => h -> p -> h-(&) = addProp+(&)+	::+		( IsProp p+		, MetaTypes y ~ GetMetaTypes p+		, CheckCombinable x y ~ 'CanCombine+		)+	=> Props (MetaTypes x)+	-> p+	-> Props (MetaTypes (Combine x y))+Props c & p = Props (c ++ [toChildProperty p])  -- | Adds a property before any other properties.-(&^) :: (PropAccum h, IsProp p) => h -> p -> h-(&^) = addPropFront+(&^)+	::+		( IsProp p+		, MetaTypes y ~ GetMetaTypes p+		, CheckCombinable x y ~ 'CanCombine+		)+	=> Props (MetaTypes x)+	-> p+	-> Props (MetaTypes (Combine x y))+Props c &^ p = Props (toChildProperty p : c)  -- | Adds a property in reverted form.-(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h-h ! p = h & revert p--infixl 1 &-infixl 1 &^-infixl 1 !--instance PropAccum Host where-	(Host hn ps is) `addProp`  p = Host hn (ps ++ [toProp p])-		(is <> getInfoRecursive p)-	(Host hn ps is) `addPropFront` p = Host hn (toProp p : ps)-		(getInfoRecursive p <> is)-	getProperties = hostProperties+(!)+	:: (CheckCombinable x z ~ 'CanCombine)+	=> Props (MetaTypes x)+	-> RevertableProperty (MetaTypes y) (MetaTypes z)+	-> Props (MetaTypes (Combine x z))+Props c ! p = Props (c ++ [toChildProperty (revert p)]) --- | Adjust the provided Property, adding to its--- propertyChidren the properties of the provided container.--- --- The Info of the propertyChildren is adjusted to only include --- info that should be propagated out to the Property.------ Any PrivInfo that uses HostContext is adjusted to use the name--- of the container as its context.-propagateContainer-	:: (PropAccum container)-	=> String-	-> container-	-> Property HasInfo-	-> Property HasInfo-propagateContainer containername c prop = infoProperty-	(propertyDesc prop)-	(propertySatisfy prop)-	(propertyInfo prop)-	(propertyChildren prop ++ hostprops)-  where-	hostprops = map go $ getProperties c-	go p = -		let i = mapInfo (forceHostContext containername)-			(propagatableInfo (propertyInfo p))-		    cs = map go (propertyChildren p)-		in infoProperty (propertyDesc p) (propertySatisfy p) i cs+-- addPropsHost :: Host -> [Prop] -> Host+-- addPropsHost (Host hn ps i) p = Host hn ps' i'+--   where+-- 	ps' = ps ++ [toChildProperty p]+-- 	i' = i <> getInfoRecursive p

@@ -1,5 +1,9 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}  module Propellor.Property ( 	-- * Property combinators@@ -18,9 +22,13 @@ 	-- * Constructing properties 	, Propellor 	, property+	, property'+	, OuterMetaTypesWitness 	, ensureProperty+	, pickOS 	, withOS 	, unsupportedOS+	, unsupportedOS' 	, makeChange 	, noChange 	, doNothing@@ -44,22 +52,21 @@ import "mtl" Control.Monad.RWS.Strict import System.Posix.Files import qualified Data.Hash.MD5 as MD5+import Data.List import Control.Applicative import Prelude  import Propellor.Types+import Propellor.Types.Core import Propellor.Types.ResultCheck+import Propellor.Types.MetaTypes+import Propellor.Types.Singletons import Propellor.Info-import Propellor.Exception+import Propellor.EnsureProperty import Utility.Exception import Utility.Monad import Utility.Misc --- | 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.@@ -164,13 +171,6 @@ (==>) = flip describe infixl 1 ==> --- | For when code running in the Propellor monad needs to ensure a--- Property.------ This can only be used on a Property that has NoInfo.-ensureProperty :: Property NoInfo -> Propellor Result-ensureProperty = catchPropellor . propertySatisfy- -- | Tries the first property, but if it fails to work, instead uses -- the second. fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2@@ -249,28 +249,96 @@   where 	mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f --- | Makes a property that is satisfied differently depending on the host's--- operating system. +-- | Picks one of the two input properties to use,+-- depending on the targeted OS. ----- Note that the operating system may not be declared for all hosts.+-- If both input properties support the targeted OS, then the+-- first will be used. ----- > myproperty = withOS "foo installed" $ \o -> case o of--- > 	(Just (System (Debian suite) arch)) -> ...--- > 	(Just (System (Buntish release) arch)) -> ...--- >	Nothing -> unsupportedOS-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo-withOS desc a = property desc $ a =<< getOS+-- The resulting property will use the description of the first property+-- no matter which property is used in the end. So, it's often a good+-- idea to change the description to something clearer.+--+-- For example:+--+-- > upgraded :: UnixLike+-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)+-- > 	`describe` "OS upgraded"+--+-- If neither input property supports the targeted OS, calls+-- `unsupportedOS`. Using the example above on a Fedora system would+-- fail that way.+pickOS+	::+		( SingKind ('KProxy :: KProxy ka)+		, SingKind ('KProxy :: KProxy kb)+		, DemoteRep ('KProxy :: KProxy ka) ~ [MetaType]+		, DemoteRep ('KProxy :: KProxy kb) ~ [MetaType]+		, SingI c+		-- Would be nice to have this constraint, but+		-- union will not generate metatypes lists with the same+		-- order of OS's as is used everywhere else. So, +		-- would need a type-level sort.+		--, Union a b ~ c+		)+	=> Property (MetaTypes (a :: ka))+	-> Property (MetaTypes (b :: kb))+	-> Property (MetaTypes c)+pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]+  where+	-- This use of getSatisfy is safe, because both a and b+	-- are added as children, so their info will propigate.+	c = withOS (getDesc a) $ \_ o ->+		if matching o a+			then getSatisfy a+			else if matching o b+				then getSatisfy b+				else unsupportedOS'+	matching Nothing _ = False+	matching (Just o) p = +		Targeting (systemToTargetOS o)+			`elem`+		fromSing (proptype p)+	proptype (Property t _ _ _ _) = t +-- | Makes a property that is satisfied differently depending on specifics+-- of the host's operating system.+--+-- > myproperty :: Property Debian+-- > myproperty = withOS "foo installed" $ \w o -> case o of+-- > 	(Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...+-- > 	(Just (System (Debian suite) arch)) -> ensureProperty w ...+-- >	_ -> unsupportedOS'+--+-- Note that the operating system specifics may not be declared for all hosts,+-- which is where Nothing comes in.+withOS+	:: (SingI metatypes)+	=> Desc+	-> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result)+	-> Property (MetaTypes metatypes)+withOS desc a = property desc $ a dummyoutermetatypes =<< getOS+  where+	-- Using this dummy value allows ensureProperty to be used+	-- even though the inner property probably doesn't target everything+	-- that the outer withOS property targets.+	dummyoutermetatypes :: OuterMetaTypesWitness ('[])+	dummyoutermetatypes = OuterMetaTypesWitness sing++-- | A property that always fails with an unsupported OS error.+unsupportedOS :: Property UnixLike+unsupportedOS = property "unsupportedOS" unsupportedOS'+ -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS.-unsupportedOS :: Propellor a-unsupportedOS = go =<< getOS-  where-	go Nothing = error "Unknown host OS is not supported by this property."-	go (Just o) = error $ "This property is not implemented for " ++ show o+unsupportedOS' :: Propellor Result+unsupportedOS' = go =<< getOS+	  where+		go Nothing = error "Unknown host OS is not supported by this property."+		go (Just o) = error $ "This property is not implemented for " ++ show o  -- | Undoes the effect of a RevertableProperty.-revert :: RevertableProperty i -> RevertableProperty i+revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1  makeChange :: IO () -> Propellor Result@@ -279,7 +347,7 @@ noChange :: Propellor Result noChange = return NoChange -doNothing :: Property NoInfo+doNothing :: SingI t => Property (MetaTypes t) doNothing = property "noop property" noChange  -- | Registers an action that should be run at the very end, after

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+ -- | Maintainer: Jelmer Vernooij <jelmer@samba.org>  module Propellor.Property.Aiccu (@@ -14,10 +16,10 @@ import qualified Propellor.Property.Service as Service import qualified Propellor.Property.File as File -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["aiccu"] -restarted :: Property NoInfo+restarted :: Property DebianLike restarted = Service.restarted "aiccu"  confPath :: FilePath@@ -41,12 +43,12 @@  -- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId -- and sixx.net UserName.-hasConfig :: TunnelId -> UserName -> Property HasInfo-hasConfig t u = prop  `onChange` restarted+hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike)+hasConfig t u = prop `onChange` restarted   where+  	prop :: Property (HasInfo + UnixLike) 	prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $-		property "aiccu configured" . writeConfig-	writeConfig :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result-	writeConfig getpassword = getpassword $ ensureProperty . go+		property' "aiccu configured" . writeConfig+	writeConfig getpassword w = getpassword $ ensureProperty w . go 	go (Password u', p) = confPath `File.hasContentProtected` config u' t p 	go (f, _) = error $ "Unexpected type of privdata: " ++ show f

@@ -6,50 +6,50 @@ import qualified Propellor.Property.Service as Service import qualified Propellor.Property.LetsEncrypt as LetsEncrypt -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["apache2"] -restarted :: Property NoInfo+restarted :: Property DebianLike restarted = Service.restarted "apache2" -reloaded :: Property NoInfo+reloaded :: Property DebianLike reloaded = Service.reloaded "apache2"  type ConfigLine = String  type ConfigFile = [ConfigLine] -siteEnabled :: Domain -> ConfigFile -> RevertableProperty NoInfo+siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike siteEnabled domain cf = siteEnabled' domain cf <!> siteDisabled domain -siteEnabled' :: Domain -> ConfigFile -> Property NoInfo-siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain)-	[ siteAvailable domain cf+siteEnabled' :: Domain -> ConfigFile -> Property DebianLike+siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props+	& siteAvailable domain cf 		`requires` installed 		`onChange` reloaded-	, check (not <$> isenabled)+	& check (not <$> isenabled) 		(cmdProperty "a2ensite" ["--quiet", domain]) 			`requires` installed 			`onChange` reloaded-	]   where 	isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain] -siteDisabled :: Domain -> Property NoInfo+siteDisabled :: Domain -> Property DebianLike siteDisabled domain = combineProperties 	("apache site disabled " ++ domain)-	(map File.notPresent (siteCfg domain))+	(toProps $ map File.notPresent (siteCfg domain)) 		`onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange) 		`requires` installed 		`onChange` reloaded -siteAvailable :: Domain -> ConfigFile -> Property NoInfo+siteAvailable :: Domain -> ConfigFile -> Property DebianLike siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $-	map (`File.hasContent` (comment:cf)) (siteCfg domain)+	toProps $ map tightenTargets $+		map (`File.hasContent` (comment:cf)) (siteCfg domain)   where 	comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty NoInfo+modEnabled :: String -> RevertableProperty DebianLike DebianLike modEnabled modname = enable <!> disable   where 	enable = check (not <$> isenabled)@@ -68,7 +68,7 @@ -- -- Note that ports are also specified inside a site's config file, -- so that also needs to be changed.-listenPorts :: [Port] -> Property NoInfo+listenPorts :: [Port] -> Property DebianLike listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps 	`onChange` restarted   where@@ -89,7 +89,7 @@ -- -- 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 :: Property DebianLike multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $ 	"/etc/apache2/conf.d/ssl" `File.hasContent` 		[ "NameVirtualHost *:443"@@ -129,11 +129,11 @@  -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file. Not https capable.-virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo+virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike virtualHost domain port docroot = virtualHost' domain port docroot []  -- | Like `virtualHost` but with additional config lines added.-virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo+virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike virtualHost' domain port docroot addedcfg = siteEnabled domain $ 	[ "<VirtualHost *:" ++ fromPort port ++ ">" 	, "ServerName " ++ domain ++ ":" ++ fromPort port@@ -159,11 +159,11 @@ -- -- Note that reverting this property does not remove the certificate from -- letsencrypt's cert store.-httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty NoInfo+httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos []  -- | Like `httpsVirtualHost` but with additional config lines added.-httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty NoInfo+httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown   where 	setup = setuphttp@@ -185,13 +185,13 @@ 			, "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" 			] 	setuphttps = LetsEncrypt.letsEncrypt letos domain docroot-		`onChange` combineProperties (domain ++ " ssl cert installed")-			[ File.dirExists (takeDirectory cf)-			, File.hasContent cf sslvhost-				`onChange` reloaded-			-- always reload since the cert has changed-			, reloaded-			]+		`onChange` postsetuphttps+	postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props+		& File.dirExists (takeDirectory cf)+		& File.hasContent cf sslvhost+			`onChange` reloaded+		-- always reload since the cert has changed+		& reloaded 	  where 		cf = sslconffile "letsencrypt" 		sslvhost = vhost (Port 443)

@@ -75,42 +75,41 @@ 		in [l, srcLine l] 	| otherwise = [] --- | Makes sources.list have a standard content using the mirror CDN,+-- | Makes sources.list have a standard content using the Debian mirror CDN, -- with the Debian suite configured by the os. -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org.-stdSourcesList :: Property 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"+stdSourcesList :: Property Debian+stdSourcesList = withOS "standard sources.list" $ \w o -> case o of+	(Just (System (Debian suite) _)) ->+		ensureProperty w $ stdSourcesListFor suite+	_ -> unsupportedOS' -stdSourcesListFor :: DebianSuite -> Property NoInfo+stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite []  -- | Adds additional sources.list generators. -- -- Note that if a Property needs to enable an apt source, it's better -- to do so via a separate file in </etc/apt/sources.list.d/>-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo-stdSourcesList' suite more = setSourcesList+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian+stdSourcesList' suite more = tightenTargets $ setSourcesList 	(concatMap (\gen -> gen suite) generators) 	`describe` ("standard sources.list for " ++ show suite)   where 	generators = [debCdn, kernelOrg, securityUpdates] ++ more -setSourcesList :: [Line] -> Property NoInfo+setSourcesList :: [Line] -> Property DebianLike setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update -setSourcesListD :: [Line] -> FilePath -> Property NoInfo+setSourcesListD :: [Line] -> FilePath -> Property DebianLike setSourcesListD ls basename = f `File.hasContent` ls `onChange` update   where 	f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> UncheckedProperty NoInfo-runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv+runApt :: [String] -> UncheckedProperty DebianLike+runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv  noninteractiveEnv :: [(String, String)] noninteractiveEnv =@@ -118,68 +117,67 @@ 		, ("APT_LISTCHANGES_FRONTEND", "none") 		] -update :: Property NoInfo-update = combineProperties ("apt update")-	[ pendingConfigured-	, runApt ["update"]+update :: Property DebianLike+update = combineProperties ("apt update") $ props+	& pendingConfigured+	& runApt ["update"] 		`assume` MadeChange-	]  -- | Have apt upgrade packages, adding new packages and removing old as -- necessary.-upgrade :: Property NoInfo+upgrade :: Property DebianLike upgrade = upgrade' "dist-upgrade" -upgrade' :: String -> Property NoInfo-upgrade' p = combineProperties ("apt " ++ p)-	[ pendingConfigured-	, runApt ["-y", p]+upgrade' :: String -> Property DebianLike+upgrade' p = combineProperties ("apt " ++ p) $ props+	& pendingConfigured+	& runApt ["-y", p] 		`assume` MadeChange-	]  -- | Have apt upgrade packages, but never add new packages or remove -- old packages. Not suitable for upgrading acrocess major versions -- of the distribution.-safeUpgrade :: Property NoInfo+safeUpgrade :: Property DebianLike safeUpgrade = upgrade' "upgrade"  -- | Have dpkg try to configure any packages that are not fully configured.-pendingConfigured :: Property NoInfo-pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv-	`assume` MadeChange-	`describe` "dpkg configured pending"+pendingConfigured :: Property DebianLike+pendingConfigured = tightenTargets $+	cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv+		`assume` MadeChange+		`describe` "dpkg configured pending"  type Package = String -installed :: [Package] -> Property NoInfo+installed :: [Package] -> Property DebianLike installed = installed' ["-y"] -installed' :: [String] -> [Package] -> Property NoInfo+installed' :: [String] -> [Package] -> Property DebianLike installed' params ps = robustly $ check (isInstallable ps) go 	`describe` unwords ("apt installed":ps)   where 	go = runApt (params ++ ["install"] ++ ps) -installedBackport :: [Package] -> Property NoInfo-installedBackport ps = withOS desc $ \o -> case o of+installedBackport :: [Package] -> Property Debian+installedBackport ps = withOS desc $ \w o -> case o of 	(Just (System (Debian suite) _)) -> case backportSuite suite of-		Nothing -> unsupportedOS-		Just bs -> ensureProperty $+		Nothing -> unsupportedOS'+		Just bs -> ensureProperty w $ 			runApt (["install", "-t", bs, "-y"] ++ ps) 				`changesFile` dpkgStatus-	_ -> unsupportedOS+	_ -> unsupportedOS'   where 	desc = unwords ("apt installed backport":ps)  -- | Minimal install of package, without recommends.-installedMin :: [Package] -> Property NoInfo+installedMin :: [Package] -> Property DebianLike installedMin = installed' ["--no-install-recommends", "-y"] -removed :: [Package] -> Property NoInfo+removed :: [Package] -> Property DebianLike removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) 	`describe` unwords ("apt removed":ps) -buildDep :: [Package] -> Property NoInfo+buildDep :: [Package] -> Property DebianLike buildDep ps = robustly $ go 	`changesFile` dpkgStatus 	`describe` unwords ("apt build-dep":ps)@@ -189,7 +187,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 NoInfo+buildDepIn :: FilePath -> Property DebianLike buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv 	`changesFile` dpkgStatus 	`requires` installedMin ["devscripts", "equivs"]@@ -198,14 +196,8 @@  -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry.-robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i-robustly p = adjustPropertySatisfy p $ \satisfy -> do-	r <- satisfy-	if r == FailedChange-		-- Safe to use ignoreInfo because we're re-running-		-- the same property.-		then ensureProperty $ ignoreInfo $ p `requires` update-		else return r+robustly :: Property DebianLike -> Property DebianLike+robustly p = p `fallback` (update `before` p)  isInstallable :: [Package] -> IO Bool isInstallable ps = do@@ -230,13 +222,13 @@ 		environ <- addEntry "LANG" "C" <$> getEnvironment 		readProcessEnv "apt-cache" ("policy":ps) (Just environ) -autoRemove :: Property NoInfo+autoRemove :: Property DebianLike autoRemove = runApt ["-y", "autoremove"] 	`changesFile` dpkgStatus 	`describe` "apt autoremove"  -- | Enables unattended upgrades. Revert to disable.-unattendedUpgrades :: RevertableProperty NoInfo+unattendedUpgrades :: RevertableProperty DebianLike DebianLike unattendedUpgrades = enable <!> disable   where 	enable = setup True@@ -255,11 +247,12 @@ 			| enabled = "true" 			| otherwise = "false" -	configure = withOS "unattended upgrades configured" $ \o ->+	configure :: Property DebianLike+	configure = withOS "unattended upgrades configured" $ \w o -> 		case o of 			-- the package defaults to only upgrading stable 			(Just (System (Debian suite) _))-				| not (isStable suite) -> ensureProperty $+				| not (isStable suite) -> ensureProperty w $ 					"/etc/apt/apt.conf.d/50unattended-upgrades" 						`File.containsLine` 					("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")@@ -271,10 +264,13 @@  -- | Preseeds debconf values and reconfigures the package so it takes -- effect.-reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo-reConfigure package vals = reconfigure `requires` setselections-	`describe` ("reconfigure " ++ package)+reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike+reConfigure package vals = tightenTargets $ +	reconfigure +		`requires` setselections+		`describe` ("reconfigure " ++ package)   where+	setselections :: Property DebianLike 	setselections = property "preseed" $ 		if null vals 			then noChange@@ -291,7 +287,7 @@ -- -- Assumes that there is a 1:1 mapping between service names and apt -- package names.-serviceInstalledRunning :: Package -> Property NoInfo+serviceInstalledRunning :: Package -> Property DebianLike serviceInstalledRunning svc = Service.running svc `requires` installed [svc]  data AptKey = AptKey@@ -299,10 +295,10 @@ 	, pubkey :: String 	} -trustsKey :: AptKey -> RevertableProperty NoInfo+trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike trustsKey k = trustsKey' k <!> untrustKey k -trustsKey' :: AptKey -> Property NoInfo+trustsKey' :: AptKey -> Property DebianLike trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do 	withHandle StdinHandle createProcessSuccess 		(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do@@ -313,21 +309,21 @@ 	desc = "apt trusts key " ++ keyname k 	f = aptKeyFile k -untrustKey :: AptKey -> Property NoInfo-untrustKey = File.notPresent . aptKeyFile+untrustKey :: AptKey -> Property DebianLike+untrustKey = tightenTargets . File.notPresent . aptKeyFile  aptKeyFile :: AptKey -> FilePath aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"  -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space.-cacheCleaned :: Property NoInfo-cacheCleaned = cmdProperty "apt-get" ["clean"]+cacheCleaned :: Property DebianLike+cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"] 	`assume` NoChange 	`describe` "apt cache cleaned"  -- | Add a foreign architecture to dpkg and apt.-hasForeignArch :: String -> Property NoInfo+hasForeignArch :: String -> Property DebianLike hasForeignArch arch = check notAdded (add `before` update) 	`describe` ("dpkg has foreign architecture " ++ arch)   where

@@ -0,0 +1,115 @@+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>+--+-- Personal Package Archives+module Propellor.Property.Apt.PPA where++import Data.List+import Control.Applicative+import Prelude+import Data.String.Utils+import Data.String (IsString(..))+import Propellor.Base+import qualified Propellor.Property.Apt as Apt++-- | Ensure software-properties-common is installed.+installed :: Property DebianLike+installed = Apt.installed ["software-properties-common"]++-- | Personal Package Archives are people's individual package+-- contributions to the Buntish distro. There's a well-known format for+-- representing them, and this type represents that. It's also an instance+-- of 'Show' and 'IsString' so it can work with 'OverloadedStrings'. +-- More on PPAs can be found at <https://help.launchpad.net/Packaging/PPA>+data PPA = PPA+	{ ppaAccount :: String -- ^ The Launchpad account hosting this archive.+	, ppaArchive :: String -- ^ The name of the archive.+	} deriving (Eq, Ord)++instance Show PPA where+	show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p]++instance IsString PPA where+	-- | Parse strings like "ppa:zfs-native/stable" into a PPA.+	fromString s =+		let+			[_, ppa] = split "ppa:" s+			[acct, arch] = split "/" ppa+		in+			PPA acct arch++-- | Adds a PPA to the local system repositories.+addPpa :: PPA -> Property DebianLike+addPpa p =+	cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv+	`assume` MadeChange+	`describe` ("Added PPA " ++ (show p))+	`requires` installed++-- | A repository key ID to be downloaded with apt-key.+data AptKeyId = AptKeyId+	{ akiName :: String+	, akiId :: String+	, akiServer :: String+	} deriving (Eq, Ord)++instance Show AptKeyId where+	show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k]++-- | Adds an 'AptKeyId' from the specified GPG server.+addKeyId :: AptKeyId -> Property DebianLike+addKeyId keyId =+	check keyTrusted akcmd+	`describe` (unwords ["Add third-party Apt key", show keyId])+  where+	akcmd =+		tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId]+	keyTrusted =+		let+			pks ls = concatMap (drop 1 . split "/")+				$ concatMap (take 1 . drop 1 . words)+				$ filter (\l -> "pub" `isPrefixOf` l)+					$ lines ls+			nkid = take 8 (akiId keyId)+		in+			(isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"]++-- | An Apt source line that apt-add-repository will just add to+-- sources.list. It's also an instance of both 'Show' and 'IsString' to make+-- using 'OverloadedStrings' in the configuration file easier.+--+-- | FIXME there's apparently an optional "options" fragment that I've+-- definitely not parsed here.+data AptSource = AptSource+	{ asURL :: Apt.Url -- ^ The URL hosting the repository+	, asSuite :: String  -- ^ The operating system suite+	, asComponents :: [String] -- ^ The list of components to install from this repository.+	} deriving (Eq, Ord)++instance Show AptSource where+	show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc]++instance IsString AptSource where+	fromString s =+		let+			url:suite:comps = drop 1 . words $ s+		in+			AptSource url suite comps++-- | A repository for apt-add-source, either a PPA or a regular repository line.+data AptRepository = AptRepositoryPPA PPA | AptRepositorySource AptSource++-- | Adds an 'AptRepository' using apt-add-source.+addRepository :: AptRepository -> Property DebianLike+addRepository (AptRepositoryPPA p) = addPpa p+addRepository (AptRepositorySource src) =+	check repoExists addSrc+	`describe` unwords ["Adding APT repository", show src]+	`requires` installed+  where+	allSourceLines =+		readProcess "/bin/sh" ["-c", "cat /etc/apt/sources.list /etc/apt/sources.list.d/*"]+	activeSources = map (\s -> fromString s :: AptSource )+		. filter (not . isPrefixOf "#")+		. filter (/= "") . lines <$> allSourceLines+	repoExists = isInfixOf [src] <$> activeSources+	addSrc = cmdProperty "apt-add-source" [show src]

@@ -19,9 +19,11 @@ ) where  import Propellor.Base+import Propellor.Container import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info+import Propellor.Types.Core import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd@@ -40,24 +42,24 @@ data Chroot where 	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot +instance IsContainer Chroot where+	containerProperties (Chroot _ _ h) = containerProperties h+	containerInfo (Chroot _ _ h) = containerInfo h+	setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)+ chrootSystem :: Chroot -> Maybe System-chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))+chrootSystem = fromInfoVal . fromInfo . containerInfo  instance Show Chroot where 	show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -instance PropAccum Chroot where-	(Chroot l c h) `addProp` p = Chroot l c (h & p)-	(Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p)-	getProperties (Chroot _ _ h) = hostProperties h- -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where 	-- | Do initial bootstrapping of an operating system in a chroot. 	-- If the operating System is not supported, return 	-- Left error message.-	buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)+	buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux)  -- | Use this to bootstrap a chroot by extracting a tarball. --@@ -68,14 +70,14 @@ data ChrootTarball = ChrootTarball FilePath  instance ChrootBootstrapper ChrootTarball where-	buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb+	buildchroot (ChrootTarball tb) _ loc = Right $+		tightenTargets $ extractTarball loc tb -extractTarball :: FilePath -> FilePath -> Property HasInfo-extractTarball target src = toProp .-	check (unpopulated target) $-		cmdProperty "tar" params-			`assume` MadeChange-			`requires` File.dirExists target+extractTarball :: FilePath -> FilePath -> Property UnixLike+extractTarball target src = check (unpopulated target) $+	cmdProperty "tar" params+		`assume` MadeChange+		`requires` File.dirExists target   where 	params = 		[ "-C"@@ -92,28 +94,27 @@ 		(Just s@(System (Debian _) _)) -> Right $ debootstrap s 		(Just s@(System (Buntish _) _)) -> Right $ debootstrap s 		(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."-		Nothing -> Left "Cannot debootstrap; `os` property not specified"+		Nothing -> Left "Cannot debootstrap; OS not specified" 	  where 		debootstrap s = Debootstrap.built loc s cf  -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. At a minimum,--- add the `os` property to specify the operating system to bootstrap.+-- add a property such as `osDebian` to specify the operating system+-- to bootstrap. ----- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"--- >	& os (System (Debian Unstable) "amd64")+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props+-- >	& osDebian Unstable "amd64" -- >	& Apt.installed ["ghc", "haskell-platform"] -- >	& ...-debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot debootstrapped conf = bootstrapped (Debootstrapped conf)  -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper.-bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot-bootstrapped bootstrapper location = Chroot location bootstrapper h-  where-	h = Host location [] mempty+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot+bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)  -- | Ensures that the chroot exists and is provisioned according to its -- properties.@@ -121,43 +122,44 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped.-provisioned :: Chroot -> RevertableProperty HasInfo+provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux provisioned c = provisioned' (propagateChrootInfo c) c False -provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo+provisioned'+	:: (Property Linux -> Property (HasInfo + Linux))+	-> Chroot+	-> Bool+	-> RevertableProperty (HasInfo + Linux) Linux provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =-	(propigator $ propertyList (chrootDesc c "exists") [setup])+	(propigator $ setup `describe` chrootDesc c "exists") 		<!>-	(propertyList (chrootDesc c "removed") [teardown])+	(teardown `describe` chrootDesc c "removed")   where+	setup :: Property Linux 	setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly-		`requires` toProp built+		`requires` built  	built = case buildchroot bootstrapper (chrootSystem c) loc of 		Right p -> p 		Left e -> cantbuild e -	cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []+	cantbuild e = property (chrootDesc c "built") (error e) +	teardown :: Property Linux 	teardown = check (not <$> unpopulated loc) $ 		property ("removed " ++ loc) $ 			makeChange (removeChroot loc) -propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'-  where-	p' = infoProperty-		(propertyDesc p)-		(propertySatisfy p)-		(propertyInfo p <> chrootInfo c)-		(propertyChildren p)+propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $+	p `setInfoProperty` chrootInfo c  chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ h) = mempty `addInfo` 	mempty { _chroots = M.singleton loc h }  -- | Propellor is run inside the chroot to provision it.-propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do 	let d = localdir </> shimdir c 	let me = localdir </> "propellor"@@ -205,7 +207,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = 	case findHostNoAlias hostlist hn of 		Nothing -> errorMessage ("cannot find host " ++ hn)-		Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of+		Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of 			Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) 			Just h -> go h   where@@ -213,11 +215,10 @@ 		changeWorkingDirectory localdir 		when onconsole forceConsole 		onlyProcess (provisioningLock loc) $ do-			r <- runPropellor (setInChroot h) $ ensureProperties $+			r <- runPropellor (setInChroot h) $ ensureChildProperties $ 				if systemdonly-					then [Systemd.installed]-					else map ignoreInfo $-						hostProperties h+					then [toChildProperty Systemd.installed]+					else hostProperties h 			flushConcurrentOutput 			putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command"@@ -255,15 +256,17 @@ -- from being started, which is often something you want to prevent when -- building a chroot. ----- This is accomplished by installing a </usr/sbin/policy-rc.d> script--- that does not let any daemons be started by packages that use+-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>+-- script that does not let any daemons be started by packages that use -- invoke-rc.d. Reverting the property removes the script.-noServices :: RevertableProperty NoInfo+--+-- This property has no effect on non-Debian systems.+noServices :: RevertableProperty UnixLike UnixLike noServices = setup <!> teardown   where 	f = "/usr/sbin/policy-rc.d" 	script = [ "#!/bin/sh", "exit 101" ]-	setup = combineProperties "no services started"+	setup = combineProperties "no services started" $ toProps 		[ File.hasContent f script 		, File.mode f (combineModes (readModes ++ executeModes)) 		]

@@ -58,10 +58,10 @@ -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success.-cmdProperty :: String -> [String] -> UncheckedProperty NoInfo+cmdProperty :: String -> [String] -> UncheckedProperty UnixLike cmdProperty cmd params = cmdProperty' cmd params id -cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty NoInfo+cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty UnixLike cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $ 	cmdResult <$> boolSystem' cmd (map Param params) mkprocess   where@@ -74,7 +74,7 @@ -- | A property that can be satisfied by running a command, -- with added environment variables in addition to the standard -- environment.-cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty NoInfo+cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty UnixLike cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do 	env' <- addEntries env <$> getEnvironment 	cmdResult <$> boolSystemEnv cmd (map Param params) (Just env')@@ -85,14 +85,14 @@ type Script = [String]  -- | A property that can be satisfied by running a script.-scriptProperty :: Script -> UncheckedProperty NoInfo+scriptProperty :: Script -> UncheckedProperty UnixLike scriptProperty script = cmdProperty "sh" ["-c", shellcmd]   where 	shellcmd = intercalate " ; " ("set -e" : script)  -- | A property that can satisfied by running a script -- as user (cd'd to their home directory).-userScriptProperty :: User -> Script -> UncheckedProperty NoInfo+userScriptProperty :: User -> Script -> UncheckedProperty UnixLike userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user]   where 	shellcmd = intercalate " ; " ("set -e" : "cd" : script)

@@ -37,6 +37,8 @@ ) where  import Propellor.Base+import Propellor.Types.Core+import Propellor.Types.MetaTypes  import Control.Concurrent import qualified Control.Concurrent.Async as A@@ -77,8 +79,8 @@ -- -- The above example will run foo and bar concurrently, and once either of -- those 2 properties finishes, will start running baz.-concurrentList :: IO Int -> Desc -> PropList -> Property HasInfo-concurrentList getn d (PropList ps) = infoProperty d go mempty ps+concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)+concurrentList getn d (Props ps) = property d go `addChildren` ps   where 	go = do 		n <- liftIO getn@@ -97,15 +99,11 @@ 			(p:rest) -> return (rest, Just p) 		case v of 			Nothing -> return r-			-- This use of propertySatisfy does not lose any-			-- Info asociated with the property, because-			-- concurrentList sets all the properties as-			-- children, and so propigates their info. 			Just p -> do 				hn <- asks hostName 				r' <- actionMessageOn hn-					(propertyDesc p)-					(propertySatisfy p)+					(getDesc p)+					(getSatisfy p) 				worker q (r <> r')  -- | Run an action with the number of capabiities increased as necessary to

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-}  -- | This module adds conductors to propellor. A conductor is a Host that -- is responsible for running propellor on other hosts@@ -73,7 +73,8 @@ 	Conductable(..), ) where -import Propellor.Base hiding (os)+import Propellor.Base+import Propellor.Container import Propellor.Spin (spin') import Propellor.PrivData.Paths import Propellor.Types.Info@@ -82,21 +83,22 @@ import qualified Data.Set as S  -- | Class of things that can be conducted.+--+-- There are instances for single hosts, and for lists of hosts.+-- With a list, each listed host will be conducted in turn. Failure to conduct+-- one host does not prevent conducting subsequent hosts in the list, but+-- will be propagated as an overall failure of the property. class Conductable c where-	conducts :: c -> RevertableProperty HasInfo+	conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)  instance Conductable Host where-	-- | Conduct the specified host. 	conducts h = conductorFor h <!> notConductorFor h --- | Each host in the list will be conducted in turn. Failure to conduct--- one host does not prevent conducting subsequent hosts in the list, but--- will be propagated as an overall failure of the property. instance Conductable [Host] where 	conducts hs = -		propertyList desc (map (toProp . conducts) hs)+		propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) 			<!>-		propertyList desc (map (toProp . revert . conducts) hs)+		propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs) 	  where 		desc = cdesc $ unwords $ map hostName hs @@ -126,7 +128,7 @@   where 	go seen h 		| S.member (hostName h) seen = Nothing -- break loop-		| otherwise = Just $ case getInfo (hostInfo h) of+		| otherwise = Just $ case fromInfo (hostInfo h) of 			ConductorFor [] -> Conducted h 			ConductorFor l ->  				let seen' = S.insert (hostName h) seen@@ -214,14 +216,15 @@ orchestrate hs = map go hs   where 	go h-		| isOrchestrated (getInfo (hostInfo h)) = h+		| isOrchestrated (fromInfo (hostInfo h)) = h 		| otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) 	os = extractOrchestras hs  	removeold h = foldl removeold' h (oldconductorsof h)-	removeold' h oldconductor = h & revert (conductedBy oldconductor)+	removeold' h oldconductor = setContainerProps h $ containerProps h+		! conductedBy oldconductor -	oldconductors = zip hs (map (getInfo . hostInfo) hs)+	oldconductors = zip hs (map (fromInfo . hostInfo) hs) 	oldconductorsof h = flip mapMaybe oldconductors $  		\(oldconductor, NotConductorFor l) -> 			if any (sameHost h) l@@ -232,7 +235,9 @@ orchestrate' h (Conducted _) = h orchestrate' h (Conductor c l) 	| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)-	| any (sameHost h) (map topHost l) = cont $ h & conductedBy c+	| any (sameHost h) (map topHost l) = cont $+		setContainerProps h $ containerProps h+			& conductedBy c 	| otherwise = cont h   where 	cont h' = foldl orchestrate' h' l@@ -240,14 +245,16 @@ -- The host this property is added to becomes the conductor for the -- specified Host. Note that `orchestrate` must be used for this property -- to have any effect.-conductorFor :: Host -> Property HasInfo-conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []-	`requires` toProp (conductorKnownHost h)+conductorFor :: Host -> Property (HasInfo + UnixLike)+conductorFor h = go+	`setInfoProperty` (toInfo (ConductorFor [h]))+	`requires` setupRevertableProperty (conductorKnownHost h) 	`requires` Ssh.installed   where 	desc = cdesc (hostName h) -	go = ifM (isOrchestrated <$> askInfo)+	go :: Property UnixLike+	go = property desc $ ifM (isOrchestrated <$> askInfo) 		( do 			pm <- liftIO $ filterPrivData h 				<$> readPrivDataFile privDataLocal@@ -262,13 +269,15 @@ 		)  -- Reverts conductorFor.-notConductorFor :: Host -> Property HasInfo-notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotConductorFor [h])) []-	`requires` toProp (revert (conductorKnownHost h))+notConductorFor :: Host -> Property (HasInfo + UnixLike)+notConductorFor h = (doNothing :: Property UnixLike)+	`setInfoProperty` (toInfo (NotConductorFor [h]))+	`describe` desc+	`requires` undoRevertableProperty (conductorKnownHost h)   where 	desc = "not " ++ cdesc (hostName h) -conductorKnownHost :: Host -> RevertableProperty NoInfo+conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike conductorKnownHost h =  	mk Ssh.knownHost 		<!>@@ -287,10 +296,10 @@ 	i = mempty  		`addInfo` mconcat (map privinfo hs) 		`addInfo` Orchestrated (Any True)-	privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')+	privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h')  -- Use this property to let the specified conductor ssh in and run propellor.-conductedBy :: Host -> RevertableProperty NoInfo+conductedBy :: Host -> RevertableProperty UnixLike UnixLike conductedBy h = (setup <!> teardown) 	`describe` ("conducted by " ++ hostName h)   where

@@ -37,7 +37,7 @@ 	-> AdjustSection 	-> InsertSection 	-> FilePath-	-> Property NoInfo+	-> Property UnixLike adjustSection desc start past adjust insert = fileProperty desc go   where 	go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls@@ -68,7 +68,7 @@ 	-> AdjustSection 	-> InsertSection 	-> FilePath-	-> Property NoInfo+	-> Property UnixLike adjustIniSection desc header = 	adjustSection 	desc@@ -77,7 +77,7 @@  -- | Ensures that a .ini file exists and contains a section -- with a key=value setting.-containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property NoInfo+containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike containsIniSetting f (header, key, value) = 	adjustIniSection 	(f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value)@@ -93,7 +93,7 @@ 	isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key]  -- | Ensures that a .ini file does not contain the specified section.-lacksIniSection :: FilePath -> IniSection -> Property NoInfo+lacksIniSection :: FilePath -> IniSection -> Property UnixLike lacksIniSection f header = 	adjustIniSection 	(f ++ " lacks section [" ++ header ++ "]")

@@ -27,9 +27,11 @@ -- job file. -- -- The cron job's output will only be emailed if it exits nonzero.-job :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo-job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)-	[ cronjobfile `File.hasContent`+job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike+job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props+	& Apt.serviceInstalledRunning "cron"+	& Apt.installed ["util-linux", "moreutils"]+	& cronjobfile `File.hasContent` 		[ case times of 			Times _ -> "" 			_ -> "#!/bin/sh\nset -e"@@ -44,22 +46,19 @@ 				"root" -> "chronic " ++ shellEscape scriptfile 				_ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile 		]-	, case times of+	& 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`+	& scriptfile `File.hasContent` 		[ "#!/bin/sh" 		, "# Generated by propellor" 		, "set -e" 		, "flock -n " ++ shellEscape cronjobfile 			++ " sh -c " ++ shellEscape cmdline 		]-	, scriptfile `File.mode` combineModes (readModes ++ executeModes)-	]-	`requires` Apt.serviceInstalledRunning "cron"-	`requires` Apt.installed ["util-linux", "moreutils"]+	& scriptfile `File.mode` combineModes (readModes ++ executeModes)   where 	cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" 	cronjobfile = "/etc" </> cronjobdir </> name@@ -75,13 +74,13 @@ 		| otherwise = '_'  -- | Installs a cron job, and runs it niced and ioniced.-niceJob :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo+niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike niceJob desc times user cddir command = job desc times user cddir 	("nice ionice -c 3 sh -c " ++ shellEscape command)  -- | Installs a cron job to run propellor.-runPropellor :: Times -> Property NoInfo-runPropellor times = withOS "propellor cron job" $ \o -> -	ensureProperty $+runPropellor :: Times -> Property UnixLike+runPropellor times = withOS "propellor cron job" $ \w o -> +	ensureProperty w $ 		niceJob "propellor" times (User "root") localdir 			(bootstrapPropellorCommand o ++ "; ./propellor")

@@ -119,19 +119,17 @@ debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } -mirror :: DebianMirror -> Property NoInfo-mirror mirror' = propertyList-	("Debian mirror " ++ dir)-	[ Apt.installed ["debmirror"]-	, User.accountFor (User "debmirror")-	, File.dirExists dir-	, File.ownerGroup dir (User "debmirror") (Group "debmirror")-	, check (not . and <$> mapM suitemirrored suites)+mirror :: DebianMirror -> Property DebianLike+mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props+	& Apt.installed ["debmirror"]+	& User.accountFor (User "debmirror")+	& File.dirExists dir+	& File.ownerGroup dir (User "debmirror") (Group "debmirror")+	& check (not . and <$> mapM suitemirrored suites) 		(cmdProperty "debmirror" args) 			`describe` "debmirror setup"-	, Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $-		unwords ("/usr/bin/debmirror" : args)-	]+	& Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/"+		(unwords ("/usr/bin/debmirror" : args))   where 	dir = _debianMirrorDir mirror' 	suites = _debianMirrorSuites mirror'

@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Propellor.Property.Debootstrap ( 	Url, 	DebootstrapConfig(..),@@ -48,14 +46,15 @@ -- -- The System can be any OS and architecture that debootstrap -- and the kernel support.-built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo-built target system config = built' (toProp installed) target system config+built :: FilePath -> System -> DebootstrapConfig -> Property Linux+built target system config = built' (setupRevertableProperty installed) target system config -built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)+built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux built' installprop target system@(System _ arch) config = 	check (unpopulated target <||> ispartial) setupprop 		`requires` installprop   where+	setupprop :: Property Linux 	setupprop = property ("debootstrapped " ++ target) $ liftIO $ do 		createDirectoryIfMissing True target 		-- Don't allow non-root users to see inside the chroot,@@ -99,39 +98,34 @@ -- When necessary, falls back to installing debootstrap from source. -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification.-installed :: RevertableProperty NoInfo+installed :: RevertableProperty Linux Linux installed = install <!> remove   where-	install = withOS "debootstrap installed" $ \o ->-		ifM (liftIO $ isJust <$> programPath)-			( return NoChange-			, ensureProperty (installon o)-			)--	installon (Just (System (Debian _) _)) = aptinstall-	installon (Just (System (Buntish _) _)) = aptinstall-	installon _ = sourceInstall+	install = check (isJust <$> programPath) $+		(aptinstall `pickOS` sourceInstall)+			`describe` "debootstrap installed" -	remove = withOS "debootstrap removed" $ ensureProperty . removefrom-	removefrom (Just (System (Debian _) _)) = aptremove-	removefrom (Just (System (Buntish _) _)) = aptremove-	removefrom _ = sourceRemove+	remove = (aptremove `pickOS` sourceRemove)+		`describe` "debootstrap removed"  	aptinstall = Apt.installed ["debootstrap"] 	aptremove = Apt.removed ["debootstrap"] -sourceInstall :: Property NoInfo-sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')+sourceInstall :: Property Linux+sourceInstall = go 	`requires` perlInstalled 	`requires` arInstalled+  where+	go :: Property Linux+	go = property "debootstrap installed from source" (liftIO sourceInstall') -perlInstalled :: Property NoInfo+perlInstalled :: Property Linux perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ 	liftIO $ toResult . isJust <$> firstM id 		[ yumInstall "perl" 		] -arInstalled :: Property NoInfo+arInstalled :: Property Linux arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ 	liftIO $ toResult . isJust <$> firstM id 		[ yumInstall "binutils"@@ -175,7 +169,7 @@ 				return MadeChange 			_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" -sourceRemove :: Property NoInfo+sourceRemove :: Property Linux sourceRemove = property "debootstrap not installed from source" $ liftIO $ 	ifM (doesDirectoryExist sourceInstallDir) 		( do

@@ -2,6 +2,8 @@ -- -- This module is designed to be imported unqualified. +{-# LANGUAGE TypeFamilies #-}+ module Propellor.Property.DiskImage ( 	-- * Partition specification 	module Propellor.Property.DiskImage.PartSpec,@@ -30,6 +32,7 @@ import Propellor.Property.Mount import Propellor.Property.Partition import Propellor.Property.Rsync+import Propellor.Container import Utility.Path  import Data.List (isPrefixOf, isInfixOf, sortBy)@@ -51,7 +54,8 @@ -- -- > import Propellor.Property.DiskImage ----- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d+-- > let chroot d = Chroot.debootstrapped mempty d+-- >	& osDebian Unstable "amd64" -- >	& Apt.installed ["linux-image-amd64"] -- >	& User.hasPassword (User "root") -- >	& User.accountFor (User "demo")@@ -76,44 +80,54 @@ -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image.-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageBuilt = imageBuilt' False  -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed.-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageBuilt' rebuild img mkchroot tabletype final partspec =  	imageBuiltFrom img chrootdir tabletype final partspec 		`requires` Chroot.provisioned chroot-		`requires` (cleanrebuild <!> doNothing)+		`requires` (cleanrebuild <!> (doNothing :: Property UnixLike)) 		`describe` desc   where 	desc = "built disk image " ++ img+	cleanrebuild :: Property Linux 	cleanrebuild 		| rebuild = property desc $ do 			liftIO $ removeChroot chrootdir 			return MadeChange 		| otherwise = doNothing 	chrootdir = img ++ ".chroot"-	chroot = mkchroot chrootdir-		-- Before ensuring any other properties of the chroot, avoid-		-- starting services. Reverted by imageFinalized.-		&^ Chroot.noServices-		-- First stage finalization.-		& fst final-		-- Avoid wasting disk image space on the apt cache-		& Apt.cacheCleaned+	chroot =+		let c = mkchroot chrootdir+		in setContainerProps c $ containerProps c+			-- Before ensuring any other properties of the chroot,+			-- avoid starting services. Reverted by imageFinalized.+			&^ Chroot.noServices+			-- First stage finalization.+			& fst final+			& cachesCleaned +-- | This property is automatically added to the chroot when building a+-- disk image. It cleans any caches of information that can be omitted;+-- eg the apt cache on Debian.+cachesCleaned :: Property UnixLike+cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)+  where+	skipit = doNothing :: Property UnixLike+ -- | Builds a disk image from the contents of a chroot.-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg   where 	desc = img ++ " built from " ++ chrootdir-	mkimg = property desc $ do+	mkimg = property' desc $ \w -> do 		-- unmount helper filesystems such as proc from the chroot 		-- before getting sizes 		liftIO $ unmountBelow chrootdir@@ -123,7 +137,7 @@ 		-- tie the knot! 		let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ 			map (calcsz mnts) mnts-		ensureProperty $+		ensureProperty w $ 			imageExists img (partTableSize parttable) 				`before` 			partitioned YesReallyDeleteDiskContents img parttable@@ -135,17 +149,18 @@ 		imageFinalized final mnts mntopts devs parttable 	rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo-partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> +	mconcat $ zipWith3 (go w) mnts mntopts devs   where 	desc = "partitions populated from " ++ chrootdir -	go Nothing _ _ = noChange-	go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket+	go _ Nothing _ _ = noChange+	go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket 		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) 		(const $ liftIO $ umountLazy tmpdir) 		$ \ismounted -> if ismounted-			then ensureProperty $+			then ensureProperty w $ 				syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir 			else return FailedChange @@ -203,7 +218,7 @@ -- If the file doesn't exist, or is too small, creates a new one, full of 0's. -- -- If the file is too large, truncates it down to the specified size.-imageExists :: FilePath -> ByteSize -> Property NoInfo+imageExists :: FilePath -> ByteSize -> Property Linux imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do 	ms <- catchMaybeIO $ getFileStatus img 	case ms of@@ -226,19 +241,19 @@ --  -- It's ok if the second property leaves additional things mounted -- in the partition tree.-type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))+type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo+imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = -	property "disk image finalized" $ +	property' "disk image finalized" $ \w -> 		withTmpDir "mnt" $ \top -> -			go top `finally` liftIO (unmountall top)+			go w top `finally` liftIO (unmountall top)   where-	go top = do+	go w top = do 		liftIO $ mountall top 		liftIO $ writefstab top 		liftIO $ allowservices top-		ensureProperty $ final top devs+		ensureProperty w $ final top devs 	 	-- Ordered lexographically by mount point, so / comes before /usr 	-- comes before /usr/local@@ -280,27 +295,26 @@ grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed' bios, boots)   where-	boots mnt loopdevs = combineProperties "disk image boots using grub"+	boots mnt loopdevs = combineProperties "disk image boots using grub" $ props 		-- bind mount host /dev so grub can access the loop devices-		[ bindMount "/dev" (inmnt "/dev")-		, mounted "proc" "proc" (inmnt "/proc") mempty-		, mounted "sysfs" "sys" (inmnt "/sys") mempty+		& bindMount "/dev" (inmnt "/dev")+		& mounted "proc" "proc" (inmnt "/proc") mempty+		& mounted "sysfs" "sys" (inmnt "/sys") mempty 		-- update the initramfs so it gets the uuid of the root partition-		, inchroot "update-initramfs" ["-u"]+		& inchroot "update-initramfs" ["-u"] 			`assume` MadeChange 		-- work around for http://bugs.debian.org/802717-		, check haveosprober $ inchroot "chmod" ["-x", osprober]-		, inchroot "update-grub" []+		& check haveosprober (inchroot "chmod" ["-x", osprober])+		& inchroot "update-grub" [] 			`assume` MadeChange-		, check haveosprober $ inchroot "chmod" ["+x", osprober]-		, inchroot "grub-install" [wholediskloopdev]+		& check haveosprober (inchroot "chmod" ["+x", osprober])+		& inchroot "grub-install" [wholediskloopdev] 			`assume` MadeChange 		-- sync all buffered changes out to the disk image 		-- may not be necessary, but seemed needed sometimes 		-- when using the disk image right away.-		, cmdProperty "sync" []+		& cmdProperty "sync" [] 			`assume` NoChange-		] 	  where 	  	-- cannot use </> since the filepath is absolute 		inmnt f = mnt ++ f

@@ -60,7 +60,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 HasInfo+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike primary hosts domain soa rs = setup <!> cleanup   where 	setup = setupPrimary zonefile id hosts domain soa rs@@ -70,7 +70,7 @@  	zonefile = "/etc/bind/propellor/db." ++ domain -setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike) setupPrimary zonefile mknamedconffile hosts domain soa rs = 	withwarnings baseprop 		`requires` servingZones@@ -80,9 +80,10 @@ 	indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap  	(partialzone, zonewarnings) = genZone indomain hostmap domain soa-	baseprop = infoProperty ("dns primary for " ++ domain) satisfy-		(mempty `addInfo` addNamedConf conf) []-	satisfy = do+	baseprop = primaryprop+		`setInfoProperty` (toInfo (addNamedConf conf))+	primaryprop :: Property DebianLike+	primaryprop = property ("dns primary for " ++ domain) $ do 		sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) 		let zone = partialzone 			{ zHosts = zHosts partialzone ++ rs ++ sshfps }@@ -120,11 +121,13 @@ 				in z /= oldzone || oldserial < sSerial (zSOA zone)  -cleanupPrimary :: FilePath -> Domain -> Property NoInfo+cleanupPrimary :: FilePath -> Domain -> Property DebianLike cleanupPrimary zonefile domain = check (doesFileExist zonefile) $-	property ("removed dns primary for " ++ domain)-		(makeChange $ removeZoneFile zonefile)-		`requires` namedConfWritten+	go `requires` namedConfWritten+  where+	desc = "removed dns primary for " ++ domain+	go :: Property DebianLike+	go = property desc (makeChange $ removeZoneFile zonefile)  -- | Primary dns server for a domain, secured with DNSSEC. --@@ -152,7 +155,7 @@ -- This is different from the serial number used by 'primary', so if you -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger.-signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo+signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike signedPrimary recurrance hosts domain soa rs = setup <!> cleanup   where 	setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")@@ -184,12 +187,12 @@ -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins.-secondary :: [Host] -> Domain -> RevertableProperty HasInfo+secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain  -- | This variant is useful if the primary server does not have its DNS -- configured via propellor.-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondaryFor masters hosts domain = setup <!> cleanup   where 	setup = pureInfoProperty desc (addNamedConf conf)@@ -210,7 +213,7 @@ otherServers wantedtype hosts domain = 	M.keys $ M.filter wanted $ hostMap hosts   where-	wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of+	wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of 		Nothing -> False 		Just conf -> confDnsServerType conf == wantedtype 			&& confDomain conf == domain@@ -218,15 +221,15 @@ -- | Rewrites the whole named.conf.local file to serve the zones -- configured by `primary` and `secondary`, and ensures that bind9 is -- running.-servingZones :: Property NoInfo+servingZones :: Property DebianLike servingZones = namedConfWritten 	`onChange` Service.reloaded "bind9" 	`requires` Apt.serviceInstalledRunning "bind9" -namedConfWritten :: Property NoInfo-namedConfWritten = property "named.conf configured" $ do+namedConfWritten :: Property DebianLike+namedConfWritten = property' "named.conf configured" $ \w -> do 	zs <- getNamedConf-	ensureProperty $+	ensureProperty w $ 		hasContent namedConfFile $ 			concatMap confStanza $ M.elems zs @@ -465,7 +468,7 @@ 	-- So we can just use the IPAddrs. 	addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] 	addcnames h = concatMap gen $ filter (inDomain zdomain) $-		mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info+		mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info 	  where 		info = hostInfo h 		gen c = case getAddresses info of@@ -480,7 +483,7 @@ 	  where 		info = hostInfo h 		l = zip (repeat $ AbsDomain $ hostName h)-			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info))+			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info))  	-- Simplifies the list of hosts. Remove duplicate entries. 	-- Also, filter out any CHAMES where the same domain has an@@ -515,7 +518,7 @@ 	domain = confDomain conf  getNamedConf :: Propellor (M.Map Domain NamedConf)-getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo+getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo  -- | Generates SSHFP records for hosts in the domain (or with CNAMES -- in the domain) that have configured ssh public keys.@@ -528,7 +531,7 @@ 	gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty 	mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) 		(AbsDomain hostname : cnames)-	cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info+	cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info 	hostname = hostName h 	info = hostInfo h 

@@ -7,13 +7,13 @@ -- -- signedPrimary uses this, so this property does not normally need to be -- used directly.-keysInstalled :: Domain -> RevertableProperty HasInfo+keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike keysInstalled domain = setup <!> cleanup   where-	setup = propertyList "DNSSEC keys installed" $+	setup = propertyList "DNSSEC keys installed" $ toProps $ 		map installkey keys -	cleanup = propertyList "DNSSEC keys removed" $+	cleanup = propertyList "DNSSEC keys removed" $ toProps $ 		map (File.notPresent . keyFn domain) keys  	installkey k = writer (keysrc k) (keyFn domain k) (Context domain)@@ -37,12 +37,14 @@ -- -- signedPrimary uses this, so this property does not normally need to be -- used directly.-zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo+zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike zoneSigned domain zonefile = setup <!> cleanup   where+	setup :: Property (HasInfo + UnixLike) 	setup = check needupdate (forceZoneSigned domain zonefile) 		`requires` keysInstalled domain 	+	cleanup :: Property UnixLike 	cleanup = File.notPresent (signedZoneFile zonefile) 		`before` File.notPresent dssetfile 		`before` revert (keysInstalled domain)@@ -63,7 +65,7 @@ 		t2 <- getModificationTime f 		return (t2 >= t1) -forceZoneSigned :: Domain -> FilePath -> Property NoInfo+forceZoneSigned :: Domain -> FilePath -> Property UnixLike forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do 	salt <- take 16 <$> saltSha1  	let p = proc "dnssec-signzone"

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}  -- | Docker support for propellor --@@ -48,8 +48,10 @@ import Propellor.Base hiding (init) import Propellor.Types.Docker import Propellor.Types.Container+import Propellor.Types.Core import Propellor.Types.CmdLine import Propellor.Types.Info+import Propellor.Container import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cmd as Cmd@@ -66,16 +68,17 @@ import qualified Data.Map as M import System.Console.Concurrent -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["docker.io"]  -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional.-configured :: Property HasInfo+configured :: Property (HasInfo + DebianLike) configured = prop `requires` installed   where+	prop :: Property (HasInfo + DebianLike) 	prop = withPrivData src anyContext $ \getcfg ->-		property "docker configured" $ getcfg $ \cfg -> ensureProperty $+		property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $ 			"/root/.dockercfg" `File.hasContent` privDataLines cfg 	src = PrivDataSourceFileFromCommand DockerAuthentication 		"/root/.dockercfg" "docker login"@@ -88,6 +91,11 @@ -- | A docker container. data Container = Container Image Host +instance IsContainer Container where+	containerProperties (Container _ h) = containerProperties h+	containerInfo (Container _ h) = containerInfo h+	setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps)+ class HasImage a where 	getImageName :: a -> Image @@ -97,22 +105,17 @@ instance HasImage Container where 	getImageName (Container i _) = i -instance PropAccum Container where-	(Container i h) `addProp` p = Container i (h `addProp` p)-	(Container i h) `addPropFront` p = Container i (h `addPropFront` p)-	getProperties (Container _ h) = hostProperties h- -- | Defines a Container with a given name, image, and properties.--- Properties can be added to configure the Container.+-- Add properties to configure the Container. ----- > container "web-server" "debian"+-- > container "web-server" (latestImage "debian") $ props -- >    & publish "80:80" -- >    & Apt.installed {"apache2"] -- >    & ...-container :: ContainerName -> Image -> Container-container cn image = Container image (Host cn [] info)+container :: ContainerName -> Image -> Props metatypes -> Container+container cn image (Props ps) = Container image (Host cn ps info)   where-	info = dockerInfo mempty+	info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)  -- | Ensures that a docker container is set up and running. --@@ -124,7 +127,7 @@ -- -- Reverting this property ensures that the container is stopped and -- removed.-docked :: Container -> RevertableProperty HasInfo+docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) docked ctr@(Container _ h) = 	(propagateContainerInfo ctr (go "docked" setup)) 		<!>@@ -132,11 +135,12 @@   where 	cn = hostName h -	go desc a = property (desc ++ " " ++ cn) $ do+	go desc a = property' (desc ++ " " ++ cn) $ \w -> do 		hn <- asks hostName 		let cid = ContainerId hn cn-		ensureProperties [a cid (mkContainerInfo cid ctr)]+		ensureProperty w $ a cid (mkContainerInfo cid ctr) +	setup :: ContainerId -> ContainerInfo -> Property Linux 	setup cid (ContainerInfo image runparams) = 		provisionContainer cid 			`requires`@@ -144,8 +148,9 @@ 			`requires` 		installed +	teardown :: ContainerId -> ContainerInfo -> Property Linux 	teardown cid (ContainerInfo image _runparams) =-		combineProperties ("undocked " ++ fromContainerId cid)+		combineProperties ("undocked " ++ fromContainerId cid) $ toProps 			[ stoppedContainer cid 			, property ("cleaned up " ++ fromContainerId cid) $ 				liftIO $ report <$> mapM id@@ -155,32 +160,32 @@ 			]  -- | Build the image from a directory containing a Dockerfile.-imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo-imageBuilt directory ctr = describe built msg+imageBuilt :: HasImage c => FilePath -> c -> Property Linux+imageBuilt directory ctr = built `describe` msg   where 	msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory-	built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir-		`assume` MadeChange+	built :: Property Linux+	built = tightenTargets $+		Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir+			`assume` MadeChange 	workDir p = p { cwd = Just directory } 	image = getImageName ctr  -- | Pull the image from the standard Docker Hub registry.-imagePulled :: HasImage c => c -> Property NoInfo-imagePulled ctr = describe pulled msg+imagePulled :: HasImage c => c -> Property Linux+imagePulled ctr = pulled `describe` msg   where 	msg = "docker image " ++ (imageIdentifier image) ++ " pulled"-	pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]-		`assume` MadeChange+	pulled :: Property Linux+	pulled = tightenTargets $ +		Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]+			`assume` MadeChange 	image = getImageName ctr -propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'+propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)+propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $+	p `addInfoProperty` dockerinfo   where-	p' = infoProperty-		(propertyDesc p)-		(propertySatisfy p)-		(propertyInfo p <> dockerinfo)-		(propertyChildren p) 	dockerinfo = dockerInfo $ 		mempty { _dockerContainers = M.singleton cn h } 	cn = hostName h@@ -191,8 +196,8 @@   where 	runparams = map (\(DockerRunParam mkparam) -> mkparam hn) 		(_dockerRunParams info)-	info = getInfo $ hostInfo h'-	h' = h+	info = fromInfo $ hostInfo h'+	h' = setContainerProps h $ containerProps h 		-- Restart by default so container comes up on 		-- boot or when docker is upgraded. 		&^ restartAlways@@ -209,14 +214,15 @@ -- that were not set up using propellor. -- -- Generally, should come after the properties for the desired containers.-garbageCollected :: Property NoInfo-garbageCollected = propertyList "docker garbage collected"-	[ gccontainers-	, gcimages-	]+garbageCollected :: Property Linux+garbageCollected = propertyList "docker garbage collected" $ props+	& gccontainers+	& gcimages   where+	gccontainers :: Property Linux 	gccontainers = property "docker containers garbage collected" $ 		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)+	gcimages :: Property Linux 	gcimages = property "docker images garbage collected" $ 		liftIO $ report <$> (mapM removeImage =<< listImages) @@ -225,8 +231,8 @@ -- 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 NoInfo-tweaked = cmdProperty "sh"+tweaked :: Property Linux+tweaked = tightenTargets $ cmdProperty "sh" 	[ "-c" 	, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*" 	]@@ -239,10 +245,11 @@ -- other GRUB_CMDLINE_LINUX_DEFAULT settings. -- -- Only takes effect after reboot. (Not automated.)-memoryLimited :: Property NoInfo-memoryLimited = "/etc/default/grub" `File.containsLine` cfg-	`describe` "docker memory limited"-	`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)+memoryLimited :: Property DebianLike+memoryLimited = tightenTargets $+	"/etc/default/grub" `File.containsLine` cfg+		`describe` "docker memory limited"+		`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)   where 	cmdline = "cgroup_enable=memory swapaccount=1" 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""@@ -300,15 +307,15 @@ 	imageIdentifier (ImageUID uid) = uid  -- | Set custom dns server for container.-dns :: String -> Property HasInfo+dns :: String -> Property (HasInfo + Linux) dns = runProp "dns"  -- | Set container host name.-hostname :: String -> Property HasInfo+hostname :: String -> Property (HasInfo + Linux) hostname = runProp "hostname"  -- | Set name of container.-name :: String -> Property HasInfo+name :: String -> Property (HasInfo + Linux) name = runProp "name"  class Publishable p where@@ -322,15 +329,15 @@ 	toPublish = id  -- | Publish a container's port to the host-publish :: Publishable p => p -> Property HasInfo+publish :: Publishable p => p -> Property (HasInfo + Linux) publish = runProp "publish" . toPublish  -- | Expose a container's port without publishing it.-expose :: String -> Property HasInfo+expose :: String -> Property (HasInfo + Linux) expose = runProp "expose"  -- | Username or UID for container.-user :: String -> Property HasInfo+user :: String -> Property (HasInfo + Linux) user = runProp "user"  class Mountable p where@@ -346,17 +353,17 @@ 	toMount = id  -- | Mount a volume-volume :: Mountable v => v -> Property HasInfo+volume :: Mountable v => v -> Property (HasInfo + Linux) volume = runProp "volume" . toMount  -- | Mount a volume from the specified container into the current -- container.-volumes_from :: ContainerName -> Property HasInfo+volumes_from :: ContainerName -> Property (HasInfo + Linux) volumes_from cn = genProp "volumes-from" $ \hn -> 	fromContainerId (ContainerId hn cn)  -- | Work dir inside the container.-workdir :: String -> Property HasInfo+workdir :: String -> Property (HasInfo + Linux) workdir = runProp "workdir"  -- | Memory limit for container.@@ -364,18 +371,18 @@ -- -- Note: Only takes effect when the host has the memoryLimited property -- enabled.-memory :: String -> Property HasInfo+memory :: String -> Property (HasInfo + Linux) memory = runProp "memory"  -- | CPU shares (relative weight). -- -- By default, all containers run at the same priority, but you can tell -- the kernel to give more CPU time to a container using this property.-cpuShares :: Int -> Property HasInfo+cpuShares :: Int -> Property (HasInfo + Linux) cpuShares = runProp "cpu-shares" . show  -- | Link with another container on the same host.-link :: ContainerName -> ContainerAlias -> Property HasInfo+link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux) link linkwith calias = genProp "link" $ \hn -> 	fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias @@ -387,24 +394,24 @@ -- propellor; as well as keeping badly behaved containers running, -- it ensures that containers get started back up after reboot or -- after docker is upgraded.-restartAlways :: Property HasInfo+restartAlways :: Property (HasInfo + Linux) restartAlways = runProp "restart" "always"  -- | Docker will restart the container if it exits nonzero. -- If a number is provided, it will be restarted only up to that many -- times.-restartOnFailure :: Maybe Int -> Property HasInfo+restartOnFailure :: Maybe Int -> Property (HasInfo + Linux) restartOnFailure Nothing = runProp "restart" "on-failure" restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)  -- | Makes docker not restart a container when it exits -- Note that this includes not restarting it on boot!-restartNever :: Property HasInfo+restartNever :: Property (HasInfo + Linux) restartNever = runProp "restart" "no"  -- | Set environment variable with a tuple composed by the environment -- variable name and its value.-environment :: (String, String) -> Property HasInfo+environment :: (String, String) -> Property (HasInfo + Linux) environment (k, v) = runProp "env" $ k ++ "=" ++ v  -- | A container is identified by its name, and the host@@ -441,9 +448,9 @@ containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc   where-	desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p+	desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p -runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo+runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do 	l <- liftIO $ listContainers RunningContainers 	if cid `elem` l@@ -507,6 +514,7 @@ 				retry (n-1) a 			_ -> return v +	go :: ImageIdentifier i => i -> Propellor Result 	go img = liftIO $ do 		clearProvisionedFlag cid 		createDirectoryIfMissing True (takeDirectory $ identFile cid)@@ -558,7 +566,7 @@  -- | Once a container is running, propellor can be run inside -- it to provision it.-provisionContainer :: ContainerId -> Property NoInfo+provisionContainer :: ContainerId -> Property Linux provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) 	let params = ["--continue", show $ toChain cid]@@ -580,16 +588,14 @@ 	Nothing -> errorMessage "bad container id" 	Just cid -> case findHostNoAlias hostlist hn of 		Nothing -> errorMessage ("cannot find host " ++ hn)-		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of+		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of 			Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) 			Just h -> go cid h   where 	go cid h = do 		changeWorkingDirectory localdir 		onlyProcess (provisioningLock cid) $ do-			r <- runPropellor h $ ensureProperties $-				map ignoreInfo $-					hostProperties h+			r <- runPropellor h $ ensureChildProperties $ hostProperties h 			flushConcurrentOutput 			putStrLn $ "\n" ++ show r @@ -599,15 +605,16 @@ startContainer :: ContainerId -> IO Bool startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] -stoppedContainer :: ContainerId -> Property NoInfo-stoppedContainer cid = containerDesc cid $ property desc $+stoppedContainer :: ContainerId -> Property Linux+stoppedContainer cid = containerDesc cid $ property' desc $ \w -> 	ifM (liftIO $ elem cid <$> listContainers RunningContainers)-		( liftIO cleanup `after` ensureProperty-			(property desc $ liftIO $ toResult <$> stopContainer cid)+		( liftIO cleanup `after` ensureProperty w stop 		, return NoChange 		)   where 	desc = "stopped"+	stop :: Property Linux+	stop = property desc $ liftIO $ toResult <$> stopContainer cid 	cleanup = do 		nukeFile $ identFile cid 		removeDirectoryRecursive $ shimdir cid@@ -651,14 +658,14 @@ listImages :: IO [ImageUID] listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Property HasInfo-runProp field val = pureInfoProperty (param) $+runProp :: String -> RunParam -> Property (HasInfo + Linux)+runProp field val = tightenTargets $ pureInfoProperty (param) $ 	mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }   where 	param = field++"="++val -genProp :: String -> (HostName -> RunParam) -> Property HasInfo-genProp field mkval = pureInfoProperty field $+genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)+genProp field mkval = tightenTargets $ pureInfoProperty field $ 	mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }  dockerInfo :: DockerInfo -> Info

@@ -5,24 +5,24 @@ import qualified Propellor.Property.Service as Service import Propellor.Property.ConfFile -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.serviceInstalledRunning "fail2ban" -reloaded :: Property NoInfo+reloaded :: Property DebianLike reloaded = Service.reloaded "fail2ban"  type Jail = String  -- | By default, fail2ban only enables the ssh jail, but many others -- are available to be enabled, for example "postfix-sasl"-jailEnabled :: Jail -> Property NoInfo+jailEnabled :: Jail -> Property DebianLike jailEnabled name = jailConfigured name "enabled" "true" 	`onChange` reloaded  -- | Configures a jail. For example: -- -- > jailConfigured "sshd" "port" "2222"-jailConfigured :: Jail -> IniKey -> String -> Property NoInfo+jailConfigured :: Jail -> IniKey -> String -> Property UnixLike jailConfigured name key value =  	jailConfFile name `containsIniSetting` (name, key, value) 

@@ -9,14 +9,14 @@ type Line = String  -- | Replaces all the content of a file.-hasContent :: FilePath -> [Line] -> Property NoInfo+hasContent :: FilePath -> [Line] -> Property UnixLike f `hasContent` newcontent = fileProperty 	("replace " ++ f) 	(\_oldcontent -> newcontent) f  -- | Replaces all the content of a file, ensuring that its modes do not -- allow it to be read or written by anyone other than the current user-hasContentProtected :: FilePath -> [Line] -> Property NoInfo+hasContentProtected :: FilePath -> [Line] -> Property UnixLike f `hasContentProtected` newcontent = fileProperty' writeFileProtected  	("replace " ++ f) 	(\_oldcontent -> newcontent) f@@ -25,38 +25,38 @@ -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600.-hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo+hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f  -- | Like hasPrivContent, but allows specifying a source -- for PrivData, rather than using PrivDataSourceFile .-hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) 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 HasInfo+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f -hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentExposedFrom = hasPrivContent' writeFile -hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContent' writer source f context =  	withPrivData source context $ \getcontent -> -		property desc $ getcontent $ \privcontent -> -			ensureProperty $ fileProperty' writer desc+		property' desc $ \o -> getcontent $ \privcontent -> +			ensureProperty o $ fileProperty' writer desc 				(\_oldcontent -> privDataLines privcontent) f   where 	desc = "privcontent " ++ f  -- | Ensures that a line is present in a file, adding it to the end if not.-containsLine :: FilePath -> Line -> Property NoInfo+containsLine :: FilePath -> Line -> Property UnixLike f `containsLine` l = f `containsLines` [l] -containsLines :: FilePath -> [Line] -> Property NoInfo+containsLines :: FilePath -> [Line] -> Property UnixLike f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f   where 	go content = content ++ filter (`notElem` content) ls@@ -64,27 +64,28 @@ -- | 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 NoInfo+lacksLine :: FilePath -> Line -> Property UnixLike f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f -lacksLines :: FilePath -> [Line] -> Property NoInfo+lacksLines :: FilePath -> [Line] -> Property UnixLike f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f  -- | Replaces the content of a file with the transformed content of another file-basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property NoInfo-f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f')+basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike+f `basedOn` (f', a) = property' desc $ \o -> do+	tmpl <- liftIO $ readFile f'+	ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f   where 	desc = "replace " ++ f-	go tmpl = ensureProperty $ fileProperty desc (\_ -> a $ lines $ tmpl) f  -- | Removes a file. Does not remove symlinks or non-plain-files.-notPresent :: FilePath -> Property NoInfo+notPresent :: FilePath -> Property UnixLike notPresent f = check (doesFileExist f) $ property (f ++ " not present") $  	makeChange $ nukeFile f -fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo+fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike fileProperty = fileProperty' writeFile-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)   where 	go True = do@@ -103,7 +104,7 @@ 		setOwnerAndGroup f' (fileOwner s) (fileGroup s)  -- | Ensures a directory exists.-dirExists :: FilePath -> Property NoInfo+dirExists :: FilePath -> Property UnixLike dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ 	makeChange $ createDirectoryIfMissing True d @@ -113,7 +114,7 @@ -- | Creates or atomically updates a symbolic link. -- -- Does not overwrite regular files or directories.-isSymlinkedTo :: FilePath -> LinkTarget -> Property NoInfo+isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike link `isSymlinkedTo` (LinkTarget target) = property desc $ 	go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link)   where@@ -135,7 +136,7 @@ 	updateLink = createSymbolicLink target `viaStableTmp` link  -- | Ensures that a file is a copy of another (regular) file.-isCopyOf :: FilePath -> FilePath -> Property NoInfo+isCopyOf :: FilePath -> FilePath -> Property UnixLike f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')   where 	desc = f ++ " is copy of " ++ f'@@ -156,7 +157,7 @@ 		[Param "--preserve=all", Param "--", File src, File dest]  -- | Ensures that a file/dir has the specified owner and group.-ownerGroup :: FilePath -> User -> Group -> Property NoInfo+ownerGroup :: FilePath -> User -> Group -> Property UnixLike ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)   where 	p = cmdProperty "chown" [og, f]@@ -164,7 +165,7 @@ 	og = owner ++ ":" ++ group  -- | Ensures that a file/dir has the specfied mode.-mode :: FilePath -> FileMode -> Property NoInfo+mode :: FilePath -> FileMode -> Property UnixLike mode f v = p `changesFile` f   where 	p = property (f ++ " mode " ++ show v) $ do

@@ -26,10 +26,10 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["iptables"] -rule :: Chain -> Table -> Target -> Rules -> Property NoInfo+rule :: Chain -> Table -> Target -> Rules -> Property Linux rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable   where 	r = Rule c tb tg rs

@@ -22,8 +22,8 @@ 	in 		lines <$> readProcess p a -pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo-pkgCmdProperty cmd args =+pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD+pkgCmdProperty cmd args = tightenTargets $  	let 		(p, a) = pkgCommand cmd args 	in@@ -44,13 +44,14 @@ pkgUpdated :: PkgUpdate -> Bool pkgUpdated (PkgUpdate _) = True -update :: Property HasInfo+update :: Property (HasInfo + FreeBSD) update = 	let 		upd = pkgCmd "update" [] 		go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) 	in-		infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) []+		(property "pkg update has run" go :: Property FreeBSD)+			`setInfoProperty` (toInfo (PkgUpdate ""))  newtype PkgUpgrade = PkgUpgrade String 	deriving (Typeable, Monoid, Show)@@ -60,17 +61,19 @@ pkgUpgraded :: PkgUpgrade -> Bool pkgUpgraded (PkgUpgrade _) = True -upgrade :: Property HasInfo+upgrade :: Property (HasInfo + FreeBSD) upgrade = 	let 		upd = pkgCmd "upgrade" [] 		go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) 	in-		infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update+		(property "pkg upgrade has run" go :: Property FreeBSD)+			`setInfoProperty` (toInfo (PkgUpdate ""))+			`requires` update  type Package = String -installed :: Package -> Property NoInfo+installed :: Package -> Property FreeBSD installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg]  isInstallable :: Package -> IO Bool

@@ -26,20 +26,23 @@ poudriereConfigured :: PoudriereConfigured -> Bool poudriereConfigured (PoudriereConfigured _) = True -setConfigured :: Property HasInfo-setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")+setConfigured :: Property (HasInfo + FreeBSD)+setConfigured = tightenTargets $ +	pureInfoProperty "Poudriere Configured" (PoudriereConfigured "") -poudriere :: Poudriere -> Property HasInfo+poudriere :: Poudriere -> Property (HasInfo + FreeBSD) poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop 	`requires` Pkg.installed "poudriere" 	`before` setConfigured   where-	confProp = File.containsLines poudriereConfigPath (toLines conf)+	confProp :: Property FreeBSD+	confProp = tightenTargets $+		File.containsLines poudriereConfigPath (toLines conf) 	setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS"-	prop :: CombinedType (Property NoInfo) (Property NoInfo)+	prop :: Property FreeBSD 	prop 		| isJust zfs = ((setZfs $ fromJust zfs) `before` confProp)-		| otherwise = propertyList "Configuring Poudriere without ZFS" [confProp]+		| otherwise = confProp `describe` "Configuring Poudriere without ZFS"  poudriereCommand :: String -> [String] -> (String, [String]) poudriereCommand cmd args = ("poudriere", cmd:args)@@ -58,8 +61,8 @@ jailExists :: Jail -> IO Bool jailExists (Jail name _ _) = isInfixOf [name] <$> listJails -jail :: Jail -> Property NoInfo-jail j@(Jail name version arch) =+jail :: Jail -> Property FreeBSD+jail j@(Jail name version arch) = tightenTargets $ 	let 		chk = do 			c <- poudriereConfigured <$> askInfo@@ -70,7 +73,7 @@ 		createJail = cmdProperty cmd args 	in 		check chk createJail-		`describe` unwords ["Create poudriere jail", name]+			`describe` unwords ["Create poudriere jail", name]  data JailInfo = JailInfo String 

@@ -11,7 +11,7 @@ -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd.-daemonRunning :: FilePath -> RevertableProperty NoInfo+daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike daemonRunning exportdir = setup <!> unsetup   where 	setup = containsLine conf (mkl "tcp4")@@ -47,7 +47,7 @@ 		, exportdir 		] -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["git"]  type RepoUrl = String@@ -61,8 +61,8 @@ -- it will be recursively deleted first. -- -- A branch can be specified, to check out.-cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo-cloned owner url dir mbranch = check originurl (property desc checkout)+cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike+cloned owner url dir mbranch = check originurl go 	`requires` installed   where 	desc = "git cloned " ++ url ++ " to " ++ dir@@ -74,12 +74,13 @@ 			return (v /= Just url) 		, return True 		)-	checkout = do+	go :: Property DebianLike+	go = property' desc $ \w -> do 		liftIO $ do 			whenM (doesDirectoryExist dir) $ 				removeDirectoryRecursive dir 			createDirectoryIfMissing True (takeDirectory dir)-		ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds)+		ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds) 			`assume` MadeChange 	checkoutcmds =  		-- The </dev/null fixes an intermittent@@ -99,8 +100,8 @@  data GitShared = Shared Group | SharedAll | NotShared -bareRepo :: FilePath -> User -> GitShared -> Property NoInfo-bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $+bareRepo :: FilePath -> User -> GitShared -> Property UnixLike+bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $ 	dirExists repo : case gitshared of 		NotShared -> 			[ ownerGroup repo user (userGroup user)@@ -121,7 +122,7 @@ 	isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])  -- | Set a key value pair in a git repo's configuration.-repoConfigured :: FilePath -> (String, String) -> Property NoInfo+repoConfigured :: FilePath -> (String, String) -> Property UnixLike repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $ 	userScriptProperty (User "root") 		[ "cd " ++ repo@@ -141,7 +142,7 @@ 	lines <$> readProcess "git" ["-C", repo, "config", key]  -- | Whether a repo accepts non-fast-forward pushes.-repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo+repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike repoAcceptsNonFFs repo = accepts <!> refuses   where 	accepts = repoConfigured repo ("receive.denyNonFastForwards", "false")@@ -152,7 +153,7 @@  -- | Sets a bare repository's default branch, which will be checked out -- when cloning it.-bareRepoDefaultBranch :: FilePath -> String -> Property NoInfo+bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike bareRepoDefaultBranch repo branch = 	userScriptProperty (User "root") 		[ "cd " ++ repo

@@ -6,7 +6,7 @@  import System.PosixCompat -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["gnupg"]  -- A numeric id, or a description of the key, in a form understood by gpg.@@ -22,11 +22,12 @@ -- -- Recommend only using this for low-value dedicated role keys. -- No attempt has been made to scrub the key out of memory once it's used.-keyImported :: GpgKeyId -> User -> Property HasInfo+keyImported :: GpgKeyId -> User -> Property (HasInfo + DebianLike) keyImported key@(GpgKeyId keyid) user@(User u) = prop 	`requires` installed   where 	desc = u ++ " has gpg key " ++ show keyid+	prop :: Property (HasInfo + DebianLike) 	prop = withPrivData src (Context keyid) $ \getkey -> 		property desc $ getkey $ \key' -> do 			let keylines = privDataLines key'

@@ -4,7 +4,7 @@  type GID = Int -exists :: Group -> Maybe GID -> Property NoInfo+exists :: Group -> Maybe GID -> Property UnixLike exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid)) 	`describe` unwords ["group", group']   where

@@ -19,20 +19,23 @@ -- bootloader. -- -- This includes running update-grub.-installed :: BIOS -> Property NoInfo+installed :: BIOS -> Property DebianLike installed bios = installed' bios `onChange` mkConfig  -- Run update-grub, to generate the grub boot menu. It will be -- automatically updated when kernel packages are installed.-mkConfig :: Property NoInfo-mkConfig = cmdProperty "update-grub" []+mkConfig :: Property DebianLike+mkConfig = tightenTargets $ cmdProperty "update-grub" [] 	`assume` MadeChange  -- | Installs grub; does not run update-grub.-installed' :: BIOS -> Property NoInfo-installed' bios = Apt.installed [pkg] `describe` "grub package installed"+installed' :: BIOS -> Property Linux+installed' bios = (aptinstall `pickOS` unsupportedOS)+	`describe` "grub package installed"   where-	pkg = case bios of+	aptinstall :: Property DebianLike+	aptinstall = Apt.installed [debpkg]+	debpkg = case bios of 		PC -> "grub-pc" 		EFI64 -> "grub-efi-amd64" 		EFI32 -> "grub-efi-ia32"@@ -48,8 +51,8 @@ -- 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 NoInfo-boots dev = cmdProperty "grub-install" [dev]+boots :: OSDevice -> Property Linux+boots dev = tightenTargets $ cmdProperty "grub-install" [dev] 	`assume` MadeChange 	`describe` ("grub boots " ++ dev) @@ -61,10 +64,10 @@ -- -- The rootdev should be in the form "hd0", while the bootdev is in the form -- "xen/xvda".-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo-chainPVGrub rootdev bootdev timeout = combineProperties desc-	[ File.dirExists "/boot/grub"-	, "/boot/grub/menu.lst" `File.hasContent`+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike+chainPVGrub rootdev bootdev timeout = combineProperties desc $ props+	& File.dirExists "/boot/grub"+	& "/boot/grub/menu.lst" `File.hasContent` 		[ "default 1"  		, "timeout " ++ show timeout 		, ""@@ -73,12 +76,12 @@ 		, "kernel /boot/xen-shim" 		, "boot" 		]-	, "/boot/load.cf" `File.hasContent`+	& "/boot/load.cf" `File.hasContent` 		[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]-	, installed Xen-	, flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]-		`assume` MadeChange-		`describe` "/boot-xen-shim"-	]+	& installed Xen+	& flip flagFile "/boot/xen-shim" xenshim   where 	desc = "chain PV-grub"+	xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]+		`assume` MadeChange+		`describe` "/boot-xen-shim"

@@ -6,19 +6,24 @@ import qualified Propellor.Property.User as User  -- Clean up a system as installed by cloudatcost.com-decruft :: Property NoInfo-decruft = propertyList "cloudatcost cleanup"-	[ Hostname.sane-	, "worked around grub/lvm boot bug #743126" ==>+decruft :: Property DebianLike+decruft = propertyList "cloudatcost cleanup" $ props+	& Hostname.sane+	& grubbugfix+	& nukecruft+  where+	grubbugfix :: Property DebianLike+	grubbugfix = tightenTargets $  		"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"-		`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)-		`onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)-	, combineProperties "nuked cloudatcost cruft"-		[ File.notPresent "/etc/rc.local"-		, File.notPresent "/etc/init.d/S97-setup.sh"-		, File.notPresent "/zang-debian.sh"-		, File.notPresent "/bin/npasswd"-		, User.nuked (User "user") User.YesReallyDeleteHome-		]-	]+			`describe` "worked around grub/lvm boot bug #743126"+			`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)+			`onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)+	nukecruft :: Property Linux+	nukecruft = tightenTargets $+		combineProperties "nuked cloudatcost cruft" $ props+			& File.notPresent "/etc/rc.local"+			& File.notPresent "/etc/init.d/S97-setup.sh"+			& File.notPresent "/zang-debian.sh"+			& File.notPresent "/bin/npasswd"+			& User.nuked (User "user") User.YesReallyDeleteHome 

@@ -18,16 +18,15 @@ -- 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 NoInfo-distroKernel = propertyList "digital ocean distro kernel hack"-	[ Apt.installed ["grub-pc", "kexec-tools", "file"]-	, "/etc/default/kexec" `File.containsLines`+distroKernel :: Property DebianLike+distroKernel = propertyList "digital ocean distro kernel hack" $ props+	& Apt.installed ["grub-pc", "kexec-tools", "file"]+	& "/etc/default/kexec" `File.containsLines` 		[ "LOAD_KEXEC=true" 		, "USE_GRUB_CONFIG=true" 		] `describe` "kexec configured"-	, check (not <$> runningInstalledKernel) Reboot.now+	& check (not <$> runningInstalledKernel) Reboot.now 		`describe` "running installed kernel"-	]  runningInstalledKernel :: IO Bool runningInstalledKernel = do

@@ -8,12 +8,13 @@ -- | Linode's pv-grub-x86_64 does not currently support booting recent -- Debian kernels compressed with xz. This sets up pv-grub chaining to enable -- it.-chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo+chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"  -- | Linode disables mlocate's cron job's execute permissions, -- presumably to avoid disk IO. This ensures it's executable.-mlocateEnabled :: Property NoInfo-mlocateEnabled = "/etc/cron.daily/mlocate"-	`File.mode` combineModes (readModes ++ executeModes)+mlocateEnabled :: Property DebianLike+mlocateEnabled = tightenTargets $+	"/etc/cron.daily/mlocate"+		`File.mode` combineModes (readModes ++ executeModes) 

@@ -22,20 +22,20 @@ -- 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 NoInfo+sane :: Property UnixLike sane = sane' extractDomain -sane' :: ExtractDomain -> Property NoInfo-sane' extractdomain = property ("sane hostname") $-	ensureProperty . setTo' extractdomain =<< asks hostName+sane' :: ExtractDomain -> Property UnixLike+sane' extractdomain = property' ("sane hostname") $ \w ->+	ensureProperty w . setTo' extractdomain =<< asks hostName  -- Like `sane`, but you can specify the hostname to use, instead -- of the default hostname of the `Host`.-setTo :: HostName -> Property NoInfo+setTo :: HostName -> Property UnixLike setTo = setTo' extractDomain -setTo' :: ExtractDomain -> HostName -> Property NoInfo-setTo' extractdomain hn = combineProperties desc+setTo' :: ExtractDomain -> HostName -> Property UnixLike+setTo' extractdomain hn = combineProperties desc $ toProps 	[ "/etc/hostname" `File.hasContent` [basehost] 	, hostslines $ catMaybes 		[ if null domain@@ -65,11 +65,12 @@  -- | Makes </etc/resolv.conf> contain search and domain lines for  -- the domain that the hostname is in.-searchDomain :: Property NoInfo+searchDomain :: Property UnixLike searchDomain = searchDomain' extractDomain -searchDomain' :: ExtractDomain -> Property NoInfo-searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)+searchDomain' :: ExtractDomain -> Property UnixLike+searchDomain' extractdomain = property' desc $ \w ->+	(ensureProperty w . go =<< asks hostName)   where 	desc = "resolv.conf search and domain configured" 	go hn =

@@ -5,7 +5,7 @@ import Utility.DataUnits  -- | Configures journald, restarting it so the changes take effect.-configured :: Systemd.Option -> String -> Property NoInfo+configured :: Systemd.Option -> String -> Property Linux configured option value = 	Systemd.configured "/etc/systemd/journald.conf" option value 		`onChange` Systemd.restarted "systemd-journald"@@ -14,28 +14,28 @@ -- Examples: "100 megabytes" or "0.5tb" type DataSize = String -configuredSize :: Systemd.Option -> DataSize -> Property NoInfo+configuredSize :: Systemd.Option -> DataSize -> Property Linux configuredSize option s = case readSize dataUnits s of 	Just sz -> configured option (systemdSizeUnits sz) 	Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $ 		return FailedChange -systemMaxUse :: DataSize -> Property NoInfo+systemMaxUse :: DataSize -> Property Linux systemMaxUse = configuredSize "SystemMaxUse" -runtimeMaxUse :: DataSize -> Property NoInfo+runtimeMaxUse :: DataSize -> Property Linux runtimeMaxUse = configuredSize "RuntimeMaxUse" -systemKeepFree :: DataSize -> Property NoInfo+systemKeepFree :: DataSize -> Property Linux systemKeepFree = configuredSize "SystemKeepFree" -runtimeKeepFree :: DataSize -> Property NoInfo+runtimeKeepFree :: DataSize -> Property Linux runtimeKeepFree = configuredSize "RuntimeKeepFree" -systemMaxFileSize :: DataSize -> Property NoInfo+systemMaxFileSize :: DataSize -> Property Linux systemMaxFileSize = configuredSize "SystemMaxFileSize" -runtimeMaxFileSize :: DataSize -> Property NoInfo+runtimeMaxFileSize :: DataSize -> Property Linux runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"  -- Generates size units as used in journald.conf.

@@ -34,25 +34,25 @@ principal :: String -> Maybe String -> Maybe Realm -> Principal principal p i r = p ++ maybe "" ("/"++) i ++ maybe "" ("@" ++) r -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["krb5-user"] -kdcInstalled :: Property NoInfo+kdcInstalled :: Property DebianLike kdcInstalled = Apt.serviceInstalledRunning "krb5-kdc" -adminServerInstalled :: Property NoInfo+adminServerInstalled :: Property DebianLike adminServerInstalled = Apt.serviceInstalledRunning "krb5-admin-server" -kpropServerInstalled :: Property HasInfo+kpropServerInstalled :: Property DebianLike kpropServerInstalled = propertyList "kprop server installed" $ props 	& kdcInstalled 	& Apt.installed ["openbsd-inetd"] 	& "/etc/inetd.conf" `File.containsLines`-	[ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd"-	, "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd"-	]+		[ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd"+		, "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd"+		] -kpropAcls :: [String] -> Property NoInfo+kpropAcls :: [String] -> Property UnixLike kpropAcls ps = kpropdAclPath `File.hasContent` ps `describe` "kprop server ACLs"  k5srvutil :: (Maybe FilePath) -> [String] -> IO String@@ -82,13 +82,14 @@ 	h <- homedir user 	return $ h </> ".k5login" -k5login :: User -> [Principal] -> Property NoInfo-k5login user@(User u) ps = property (u ++ " has k5login") $ do+k5login :: User -> [Principal] -> Property UnixLike+k5login user@(User u) ps = property' desc $ \w -> do 	f <- liftIO $ k5loginPath user 	liftIO $ do 		createDirectoryIfMissing True (takeDirectory f) 		writeFile f (unlines ps)-	ensureProperties-		[ File.ownerGroup f user (userGroup user)-		, File.ownerGroup (takeDirectory f) user (userGroup user)-		]+	ensureProperty w $ combineProperties desc $ props+		& File.ownerGroup f user (userGroup user)+		& File.ownerGroup (takeDirectory f) user (userGroup user)+  where+	desc = u ++ " has k5login"

@@ -7,7 +7,7 @@  import System.Posix.Files -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["letsencrypt"]  -- | Tell the letsencrypt client that you agree with the Let's Encrypt@@ -39,15 +39,16 @@ -- -- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete -- integration of apache with letsencrypt, that's built on top of this.-letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property NoInfo+letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike letsEncrypt tos domain = letsEncrypt' tos domain []  -- | Like `letsEncrypt`, but the certificate can be obtained for multiple -- domains.-letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property NoInfo+letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike letsEncrypt' (AgreeTOS memail) domain domains webroot = 	prop `requires` installed   where+	prop :: Property UnixLike 	prop = property desc $ do 		startstats <- liftIO getstats 		(transcript, ok) <- liftIO $

@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}- -- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>  module Propellor.Property.LightDM where@@ -8,11 +6,11 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.ConfFile as ConfFile -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["lightdm"]  -- | Configures LightDM to skip the login screen and autologin as a user.-autoLogin :: User -> Property NoInfo+autoLogin :: User -> Property UnixLike autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting` 	("SeatDefaults", "autologin-user", u) 	`describe` "lightdm autologin"

@@ -1,86 +1,59 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Propellor.Property.List ( 	props,-	PropertyList(..),-	PropertyListType,-	PropList(..),+	Props,+	toProps,+	propertyList,+	combineProperties, ) where  import Propellor.Types-import Propellor.Engine+import Propellor.Types.Core+import Propellor.Types.MetaTypes import Propellor.PropAccum+import Propellor.Engine+import Propellor.Exception  import Data.Monoid --- | Starts accumulating a list of properties.+toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)+toProps ps = Props (map toChildProperty ps)++-- | 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 propagate overall success/failure. --+-- For example:+-- -- > propertyList "foo" $ props--- > 	& someproperty--- > 	! oldproperty--- > 	& otherproperty-props :: PropList-props = PropList []--data PropList = PropList [Property HasInfo]--instance PropAccum PropList where-	PropList l `addProp` p = PropList (toProp p : l)-	PropList l `addPropFront` p = PropList (l ++ [toProp p])-	getProperties (PropList l) = reverse l--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 propagate 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 :: 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 [RevertableProperty NoInfo] = NoInfo-type instance PropertyListType [RevertableProperty HasInfo] = HasInfo-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 [RevertableProperty HasInfo] where-	propertyList desc ps = propertyList desc (map setupRevertableProperty ps)-	combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)--instance PropertyList [RevertableProperty NoInfo] where-	propertyList desc ps = propertyList desc (map setupRevertableProperty ps)-	combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)+-- > 	& bar+-- > 	& baz+propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)+propertyList desc (Props ps) = +	property desc (ensureChildProperties cs)+		`addChildren` cs+  where+	cs = map toChildProperty ps -instance PropertyList PropList where-	propertyList desc = propertyList desc . getProperties-	combineProperties desc = combineProperties desc . getProperties+-- | Combines a list of properties, resulting in one property that+-- ensures each in turn. Stops if a property fails.+combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)+combineProperties desc (Props ps) = +	property desc (combineSatisfy cs NoChange)+		`addChildren` cs+  where+	cs = map toChildProperty ps -combineSatisfy :: [Property i] -> Result -> Propellor Result+combineSatisfy :: [ChildProperty] -> Result -> Propellor Result combineSatisfy [] rs = return rs-combineSatisfy (l:ls) rs = do-	r <- ensureProperty $ ignoreInfo l+combineSatisfy (p:ps) rs = do+	r <- catchPropellor $ getSatisfy p 	case r of 		FailedChange -> return FailedChange-		_ -> combineSatisfy ls (r <> rs)+		_ -> combineSatisfy ps (r <> rs)

@@ -21,14 +21,17 @@ -- -- Note that reverting this property does not make a locale unavailable.  That's -- because it might be required for other Locale.selectedFor statements.-selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo+selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty DebianLike DebianLike locale `selectedFor` vars = select <!> deselect   where-	select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs)-		`requires` available locale-		`describe` (locale ++ " locale selected")-	deselect = check isselected (cmdProperty "update-locale" vars)-		`describe` (locale ++ " locale deselected")+	select = tightenTargets $ +		check (not <$> isselected) +			(cmdProperty "update-locale" selectArgs)+			`requires` available locale+			`describe` (locale ++ " locale selected")+	deselect = tightenTargets $+		check isselected (cmdProperty "update-locale" vars)+			`describe` (locale ++ " locale deselected") 	selectArgs = zipWith (++) vars (repeat ('=':locale)) 	isselected = locale `isSelectedFor` vars @@ -46,20 +49,21 @@ -- -- Per Debian bug #684134 we cannot ensure a locale is generated by means of -- Apt.reConfigure.  So localeAvailable edits /etc/locale.gen manually.-available :: Locale -> RevertableProperty NoInfo-available locale = (ensureAvailable <!> ensureUnavailable)+available :: Locale -> RevertableProperty DebianLike DebianLike+available locale = ensureAvailable <!> ensureUnavailable   where 	f = "/etc/locale.gen" 	desc = (locale ++ " locale generated")-	ensureAvailable =-		property desc $ (lines <$> (liftIO $ readFile f))-			>>= \locales ->-					if locale `presentIn` locales-					then ensureProperty $-						fileProperty desc (foldr uncomment []) f-							`onChange` regenerate-					else return FailedChange -- locale unavailable for generation-	ensureUnavailable =+	ensureAvailable :: Property DebianLike+	ensureAvailable = property' desc $ \w -> do+		locales <- lines <$> (liftIO $ readFile f)+		if locale `presentIn` locales+			then ensureProperty w $+				fileProperty desc (foldr uncomment []) f+					`onChange` regenerate+			else return FailedChange -- locale unavailable for generation+	ensureUnavailable :: Property DebianLike+	ensureUnavailable = tightenTargets $  		fileProperty (locale ++ " locale not generated") (foldr comment []) f 		`onChange` regenerate 

@@ -28,9 +28,9 @@ ignoreFilePath :: ReportLevel -> Service -> FilePath ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n -ignoreLines :: ReportLevel -> Service -> [String] -> Property NoInfo+ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls 	`describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")") -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["logcheck"]

@@ -37,16 +37,17 @@ formatMountOpts (MountOpts l) = intercalate "," l  -- | Mounts a device.-mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo+mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike mounted fs src mnt opts = property (mnt ++ " mounted") $  	toResult <$> liftIO (mount fs src mnt opts)  -- | Bind mounts the first directory so its contents also appear -- in the second directory.-bindMount :: FilePath -> FilePath -> Property NoInfo-bindMount src dest = cmdProperty "mount" ["--bind", src, dest]-	`assume` MadeChange-	`describe` ("bind mounted " ++ src ++ " to " ++ dest)+bindMount :: FilePath -> FilePath -> Property Linux+bindMount src dest = tightenTargets $+	cmdProperty "mount" ["--bind", src, dest]+		`assume` MadeChange+		`describe` ("bind mounted " ++ src ++ " to " ++ dest)  mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool mount fs src mnt opts = boolSystem "mount" $@@ -66,10 +67,10 @@ -- and its mount options are all automatically probed. -- -- The SwapPartitions are also included in the generated fstab.-fstabbed :: [MountPoint] -> [SwapPartition] -> Property NoInfo-fstabbed mnts swaps = property "fstabbed" $ do+fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux+fstabbed mnts swaps = property' "fstabbed" $ \o -> do 	fstab <- liftIO $ genFstab mnts swaps id-	ensureProperty $ +	ensureProperty o $  		"/etc/fstab" `File.hasContent` fstab  genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]

@@ -7,8 +7,8 @@  type Interface = String -ifUp :: Interface -> Property NoInfo-ifUp iface = cmdProperty "ifup" [iface]+ifUp :: Interface -> Property DebianLike+ifUp iface = tightenTargets $ cmdProperty "ifup" [iface] 	`assume` MadeChange  -- | Resets /etc/network/interfaces to a clean and empty state,@@ -18,8 +18,8 @@ -- 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+cleanInterfacesFile :: Property DebianLike+cleanInterfacesFile = tightenTargets $ hasContent interfacesFile 	[ "# Deployed by propellor, do not edit." 	, "" 	, "source-directory interfaces.d"@@ -31,8 +31,8 @@ 	`describe` ("clean " ++ interfacesFile)  -- | Configures an interface to get its address via dhcp.-dhcp :: Interface -> Property NoInfo-dhcp iface = hasContent (interfaceDFile iface)+dhcp :: Interface -> Property DebianLike+dhcp iface = tightenTargets $ hasContent (interfaceDFile iface) 	[ "auto " ++ iface 	, "iface " ++ iface ++ " inet dhcp" 	]@@ -50,18 +50,20 @@ -- -- (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+static :: Interface -> Property DebianLike+static iface = tightenTargets $ +	check (not <$> doesFileExist f) setup+		`describe` desc+		`requires` interfacesDEnabled   where 	f = interfaceDFile iface 	desc = "static " ++ iface-	setup = property desc $ do+	setup :: Property DebianLike+	setup = property' desc $ \o -> do 		ls <- liftIO $ lines <$> readProcess "ip" 			["-o", "addr", "show", iface, "scope", "global"] 		stanzas <- liftIO $ concat <$> mapM mkstanza ls-		ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas+		ensureProperty o $ 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.@@ -81,8 +83,8 @@ 			_ -> Nothing  -- | 6to4 ipv6 connection, should work anywhere-ipv6to4 :: Property NoInfo-ipv6to4 = hasContent (interfaceDFile "sit0")+ipv6to4 :: Property DebianLike+ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0") 	[ "# Deployed by propellor, do not edit." 	, "iface sit0 inet6 static" 	, "\taddress 2002:5044:5531::1"@@ -107,6 +109,8 @@ escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-"))  -- | 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"+-- interfacesDEnabled :: Property DebianLike+interfacesDEnabled :: Property DebianLike+interfacesDEnabled = tightenTargets $+	containsLine interfacesFile "source-directory interfaces.d"+		`describe` "interfaces.d directory enabled"

@@ -9,7 +9,7 @@  type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo+siteEnabled :: HostName -> ConfigFile -> RevertableProperty DebianLike DebianLike siteEnabled hn cf = enable <!> disable   where 	enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn@@ -22,11 +22,11 @@ 		`requires` installed 		`onChange` reloaded -siteAvailable :: HostName -> ConfigFile -> Property NoInfo-siteAvailable hn cf = ("nginx site available " ++ hn) ==>-	siteCfg hn `File.hasContent` (comment : cf)+siteAvailable :: HostName -> ConfigFile -> Property DebianLike+siteAvailable hn cf = "nginx site available " ++ hn ==> tightenTargets go   where 	comment = "# deployed with propellor, do not modify"+	go = siteCfg hn `File.hasContent` (comment : cf)  siteCfg :: HostName -> FilePath siteCfg hn = "/etc/nginx/sites-available/" ++ hn@@ -37,11 +37,11 @@ siteValRelativeCfg :: HostName -> File.LinkTarget siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn) -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["nginx"] -restarted :: Property NoInfo+restarted :: Property DebianLike restarted = Service.restarted "nginx" -reloaded :: Property NoInfo+reloaded :: Property DebianLike reloaded = Service.reloaded "nginx"

@@ -46,7 +46,7 @@ -- install succeeds, to bootstrap from the cleanly installed system to -- a fully working system. For example: ----- > & os (System (Debian Unstable) "amd64")+-- > & osDebian Unstable "amd64" -- > & cleanInstallOnce (Confirmed "foo.example.com") -- >    `onChange` propertyList "fixing up after clean install" -- >        [ preserveNetwork@@ -64,7 +64,7 @@ -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here-cleanInstallOnce :: Confirmation -> Property NoInfo+cleanInstallOnce :: Confirmation -> Property Linux cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ 	go `requires` confirmed "clean install confirmed" confirmation   where@@ -83,14 +83,18 @@ 			`requires` 		osbootstrapped -	osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of-		(Just d@(System (Debian _) _)) -> debootstrap d-		(Just u@(System (Buntish _) _)) -> debootstrap u-		_ -> unsupportedOS+	osbootstrapped :: Property Linux+	osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of+		(Just d@(System (Debian _) _)) -> ensureProperty w $+			debootstrap d+		(Just u@(System (Buntish _) _)) -> ensureProperty w $+			debootstrap u+		_ -> unsupportedOS' 	-	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 :: System -> Property Linux+	debootstrap targetos =+		-- Install debootstrap from source, since we don't know+		-- what OS we're currently running in. 		Debootstrap.built' Debootstrap.sourceInstall 			newOSDir targetos Debootstrap.DefaultConfig 		-- debootstrap, I wish it was faster.. @@ -100,6 +104,7 @@ 		-- sync instead?  	-- This is the fun bit.+	flipped :: Property Linux 	flipped = property (newOSDir ++ " moved into place") $ liftIO $ do 		-- First, unmount most mount points, lazily, so 		-- they don't interfere with moving things around.@@ -137,6 +142,7 @@  		return MadeChange +	propellorbootstrapped :: Property UnixLike 	propellorbootstrapped = property "propellor re-debootstrapped in new os" $ 		return NoChange 		-- re-bootstrap propellor in /usr/local/propellor,@@ -145,6 +151,7 @@ 		--   be present in /old-os's /usr/local/propellor) 		-- TODO 	+	finalized :: Property UnixLike 	finalized = property "clean OS installed" $ do 		liftIO $ writeFile flagfile "" 		return MadeChange@@ -179,7 +186,7 @@  data Confirmation = Confirmed HostName -confirmed :: Desc -> Confirmation -> Property NoInfo+confirmed :: Desc -> Confirmation -> Property UnixLike confirmed desc (Confirmed c) = property desc $ do 	hostname <- asks hostName 	if hostname /= c@@ -191,25 +198,26 @@ -- | </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 NoInfo+preserveNetwork :: Property DebianLike preserveNetwork = go `requires` Network.cleanInterfacesFile   where-	go = property "preserve network configuration" $ do+	go :: Property DebianLike+	go = property' "preserve network configuration" $ \w -> do 		ls <- liftIO $ lines <$> readProcess "ip" 			["route", "list", "scope", "global"] 		case words <$> headMaybe ls of 			Just ("default":"via":_:"dev":iface:_) ->-				ensureProperty $ Network.static iface+				ensureProperty w $ 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 NoInfo+preserveResolvConf :: Property Linux preserveResolvConf = check (fileExist oldloc) $-	property (newloc ++ " copied from old OS") $ do+	property' (newloc ++ " copied from old OS") $ \w -> do 		ls <- liftIO $ lines <$> readFile oldloc-		ensureProperty $ newloc `File.hasContent` ls+		ensureProperty w $ newloc `File.hasContent` ls   where 	newloc = "/etc/resolv.conf" 	oldloc = oldOSDir ++ newloc@@ -217,20 +225,23 @@ -- | </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 NoInfo+preserveRootSshAuthorized :: Property UnixLike preserveRootSshAuthorized = check (fileExist oldloc) $-	property (newloc ++ " copied from old OS") $ do+	property' desc $ \w -> do 		ks <- liftIO $ lines <$> readFile oldloc-		ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks)+		ensureProperty w $ combineProperties desc $+			toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks   where+	desc = newloc ++ " copied from old OS" 	newloc = "/root/.ssh/authorized_keys" 	oldloc = oldOSDir ++ newloc  -- Removes the old OS's backup from </old-os>-oldOSRemoved :: Confirmation -> Property NoInfo+oldOSRemoved :: Confirmation -> Property UnixLike oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ 	go `requires` confirmed "old OS backup removal confirmed" confirmation   where+	go :: Property UnixLike 	go = property "old OS backup removed" $ do 		liftIO $ removeDirectoryRecursive oldOSDir 		return MadeChange

@@ -40,7 +40,7 @@ -- Since obnam uses a fair amount of system resources, only one obnam -- backup job will be run at a time. Other jobs will wait their turns to -- run.-backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo+backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike backup dir crontimes params numclients = 	backup' dir crontimes params numclients 		`requires` restored dir params@@ -50,7 +50,7 @@ -- -- The gpg secret key will be automatically imported -- into root's keyring using Propellor.Property.Gpg.keyImported-backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo+backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property (HasInfo + DebianLike) backupEncrypted dir crontimes params numclients keyid = 	backup dir crontimes params' numclients 		`requires` Gpg.keyImported keyid (User "root")@@ -58,7 +58,7 @@ 	params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params  -- | Does a backup, but does not automatically restore.-backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo+backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike backup' dir crontimes params numclients = cronjob `describe` desc   where 	desc = dir ++ " backed up by obnam"@@ -96,11 +96,12 @@ -- -- The restore is performed atomically; restoring to a temp directory -- and then moving it to the directory.-restored :: FilePath -> [ObnamParam] -> Property NoInfo-restored dir params = property (dir ++ " restored by obnam") go-	`requires` installed+restored :: FilePath -> [ObnamParam] -> Property DebianLike+restored dir params = go `requires` installed   where-	go = ifM (liftIO needsRestore)+	desc = dir ++ " restored by obnam"+	go :: Property DebianLike+	go = property desc $ ifM (liftIO needsRestore) 		( do 			warningMessage $ dir ++ " is empty/missing; restoring from backup ..." 			liftIO restore@@ -152,5 +153,5 @@ isKeepParam :: ObnamParam -> Bool isKeepParam p = "--keep=" `isPrefixOf` p -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["obnam"]

@@ -16,7 +16,7 @@ -- -- It's probably a good idea to put this property inside a docker or -- systemd-nspawn container.-providerFor :: [User] -> HostName -> Maybe Port -> Property HasInfo+providerFor :: [User] -> HostName -> Maybe Port -> Property (HasInfo + DebianLike) providerFor users hn mp = propertyList desc $ props 	& Apt.serviceInstalledRunning "apache2" 	& apacheconfigured@@ -24,7 +24,7 @@ 		`onChange` Apache.restarted 	& File.fileProperty (desc ++ " configured") 		(map setbaseurl) "/etc/simpleid/config.inc"-	& propertyList desc (map identfile users)+	& propertyList desc (toProps $ map identfile users)   where 	baseurl = hn ++ case mp of 		Nothing -> ""@@ -37,7 +37,7 @@ 		| otherwise = l  	apacheconfigured = case mp of-		Nothing -> toProp $+		Nothing -> setupRevertableProperty $ 			Apache.virtualHost hn (Port 80) "/var/www/html" 		Just p -> propertyList desc $ props 			& Apache.listenPorts [p]

@@ -153,18 +153,17 @@ -- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file. -- -- This deletes any existing partitions in the disk! Use with EXTREME caution!-partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo-partitioned eep disk (PartTable tabletype parts) = property desc $ do+partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike+partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do 	isdev <- liftIO $ isBlockDevice <$> getFileStatus disk-	ensureProperty $ combineProperties desc-		[ parted eep disk partedparams-		, if isdev+	ensureProperty w $ combineProperties desc $ props+		& parted eep disk partedparams+		& if isdev 			then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) 			else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)-		]   where 	desc = disk ++ " partitioned"-	formatl devs = combineProperties desc (map format (zip parts devs))+	formatl devs = combineProperties desc (toProps $ map format (zip parts devs)) 	partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] 	format (p, dev) = Partition.formatted' (partMkFsOpts p) 		Partition.YesReallyFormatPartition (partFs p) dev@@ -193,12 +192,12 @@ -- -- Parted is run in script mode, so it will never prompt for input. -- It is asked to use cylinder alignment for the disk.-parted :: Eep -> FilePath -> [String] -> Property NoInfo+parted :: Eep -> FilePath -> [String] -> Property DebianLike parted YesReallyDeleteDiskContents disk ps = p `requires` installed   where 	p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) 		`assume` MadeChange  -- | Gets parted installed.-installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["parted"]

@@ -3,6 +3,7 @@ module Propellor.Property.Partition where  import Propellor.Base+import Propellor.Types.Core import qualified Propellor.Property.Apt as Apt import Utility.Applicative @@ -16,7 +17,7 @@ data Eep = YesReallyFormatPartition  -- | Formats a partition.-formatted :: Eep -> Fs -> FilePath -> Property NoInfo+formatted :: Eep -> Fs -> FilePath -> Property DebianLike formatted = formatted' []  -- | Options passed to a mkfs.* command when making a filesystem.@@ -24,7 +25,7 @@ -- Eg, ["-m0"] type MkfsOpts = [String] -formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo+formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts' 	`assume` MadeChange 	`requires` Apt.installed [pkg]@@ -64,17 +65,18 @@ -- within a disk image file. The resulting loop devices are passed to the -- property, which can operate on them. Always cleans up after itself, -- by removing the device maps after the property is run.-kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo+kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]   where-	go = property (propertyDesc (mkprop [])) $ do+	go :: Property DebianLike+	go = property' (getDesc (mkprop [])) $ \w -> do 		cleanup -- idempotency 		loopdevs <- liftIO $ kpartxParse 			<$> readProcess "kpartx" ["-avs", diskimage] 		bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs 		unless (null bad) $ 			error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad-		r <- ensureProperty (mkprop loopdevs)+		r <- ensureProperty w (mkprop loopdevs) 		cleanup 		return r 	cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]

@@ -12,13 +12,13 @@ import Data.List import Data.Char -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.serviceInstalledRunning "postfix" -restarted :: Property NoInfo+restarted :: Property DebianLike restarted = Service.restarted "postfix" -reloaded :: Property NoInfo+reloaded :: Property DebianLike reloaded = Service.reloaded "postfix"  -- | Configures postfix as a satellite system, which @@ -28,38 +28,39 @@ -- The smarthost may refuse to relay mail on to other domains, without -- further configuration/keys. But this should be enough to get cron job -- mail flowing to a place where it will be seen.-satellite :: Property NoInfo+satellite :: Property DebianLike satellite = check (not <$> mainCfIsSet "relayhost") setup 	`requires` installed   where-	setup = property "postfix satellite system" $ do+	desc = "postfix satellite system"+	setup :: Property DebianLike+	setup = property' desc $ \w -> do 		hn <- asks hostName 		let (_, domain) = separate (== '.') hn-		ensureProperties-			[ Apt.reConfigure "postfix"+		ensureProperty w $ combineProperties desc $ props+			& Apt.reConfigure "postfix" 				[ ("postfix/main_mailer_type", "select", "Satellite system") 				, ("postfix/root_address", "string", "root") 				, ("postfix/destinations", "string", "localhost") 				, ("postfix/mailname", "string", hn) 				]-			, mainCf ("relayhost", "smtp." ++ domain)+			& mainCf ("relayhost", "smtp." ++ domain) 				`onChange` reloaded-			]  -- | 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-	:: Combines (Property x) (Property NoInfo)+	:: Combines (Property x) (Property UnixLike) 	=> FilePath 	-> (FilePath -> Property x)-	-> Property (CInfo x NoInfo)+	-> CombinedType (Property x) (Property UnixLike) mappedFile f setup = setup f 	`onChange` (cmdProperty "postmap" [f] `assume` MadeChange)  -- | Run newaliases command, which should be done after changing -- @/etc/aliases@.-newaliases :: Property NoInfo+newaliases :: Property UnixLike newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") 	(cmdProperty "newaliases" []) @@ -68,9 +69,9 @@ mainCfFile = "/etc/postfix/main.cf"  -- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately.-mainCf :: (String, String) -> Property NoInfo+mainCf :: (String, String) -> Property UnixLike mainCf (name, value) = check notset set-		`describe` ("postfix main.cf " ++ setting)+	`describe` ("postfix main.cf " ++ setting)   where 	setting = name ++ "=" ++ value 	notset = (/= Just value) <$> getMainCf name@@ -105,7 +106,7 @@ -- -- Note that multiline configurations that continue onto the next line -- are not currently supported.-dedupMainCf :: Property NoInfo+dedupMainCf :: Property UnixLike dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile  dedupCf :: [String] -> [String]@@ -252,7 +253,7 @@ 	nws = length ws  -- | Enables a `Service` in postfix's `masterCfFile`.-service :: Service -> RevertableProperty NoInfo+service :: Service -> RevertableProperty DebianLike DebianLike service s = (enable <!> disable) 	`describe` desc   where@@ -276,7 +277,7 @@ -- It would be wise to enable fail2ban, for example: -- -- > Fail2Ban.jailEnabled "postfix-sasl"-saslAuthdInstalled :: Property NoInfo+saslAuthdInstalled :: Property DebianLike saslAuthdInstalled = setupdaemon 	`requires` Service.running "saslauthd" 	`requires` postfixgroup@@ -303,7 +304,7 @@ -- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file. -- -- The password is taken from the privdata.-saslPasswdSet :: Domain -> User -> Property HasInfo+saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike) saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"   where 	go = withPrivData src ctx $ \getpw ->

@@ -11,7 +11,7 @@ -- -- This property is useful when hosts are being updated without using -- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job.-hasOriginUrl :: String -> Property NoInfo+hasOriginUrl :: String -> Property UnixLike hasOriginUrl u = property ("propellor repo url " ++ u) $ do 	curru <- liftIO getRepoUrl 	if curru == Just u

@@ -11,7 +11,7 @@  type Conf = String -confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo+confEnabled :: Conf -> ConfigFile -> RevertableProperty DebianLike DebianLike confEnabled conf cf = enable <!> disable   where 	enable = dir `File.isSymlinkedTo` target@@ -29,9 +29,9 @@ 		`requires` installed 		`onChange` reloaded -confAvailable :: Conf -> ConfigFile -> Property NoInfo+confAvailable :: Conf -> ConfigFile -> Property DebianLike confAvailable conf cf = ("prosody conf available " ++ conf) ==>-	confAvailPath conf `File.hasContent` (comment : cf)+	tightenTargets (confAvailPath conf `File.hasContent` (comment : cf))   where 	comment = "-- deployed with propellor, do not modify" @@ -41,11 +41,11 @@ confValPath :: Conf -> FilePath confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua" -installed :: Property NoInfo+installed :: Property DebianLike installed = Apt.installed ["prosody"] -restarted :: Property NoInfo+restarted :: Property DebianLike restarted = Service.restarted "prosody" -reloaded :: Property NoInfo+reloaded :: Property DebianLike reloaded = Service.reloaded "prosody"

@@ -2,8 +2,8 @@  import Propellor.Base -now :: Property NoInfo-now = cmdProperty "reboot" []+now :: Property Linux+now = tightenTargets $ cmdProperty "reboot" [] 	`assume` MadeChange 	`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 NoInfo+atEnd :: Bool -> (Result -> Bool) -> Property Linux atEnd force resultok = property "scheduled reboot at end of propellor run" $ do 	endAction "rebooting" atend 	return NoChange

@@ -16,7 +16,7 @@  -- | Ensures that the Dest directory exists and has identical contents as -- the Src directory.-syncDir :: Src -> Dest -> Property NoInfo+syncDir :: Src -> Dest -> Property DebianLike syncDir = syncDirFiltered []  data Filter @@ -43,7 +43,7 @@ -- Rsync checks each name to be transferred against its list of Filter -- rules, and the first matching one is acted on. If no matching rule -- is found, the file is processed.-syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo+syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike syncDirFiltered filters src dest = rsync $ 	[ "-av" 	-- Add trailing '/' to get rsync to sync the Dest directory,@@ -56,7 +56,7 @@ 	, "--quiet" 	] ++ map toRsync filters -rsync :: [String] -> Property NoInfo+rsync :: [String] -> Property DebianLike rsync ps = cmdProperty "rsync" ps 	`assume` MadeChange 	`requires` Apt.installed ["rsync"]