From 6d52245a574e65275f818d90839737f0074b045f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Mar 2016 15:08:58 -0400 Subject: document status --- ...ent_2_5a1c0c54db25b039eda28e213e1e6263._comment | 43 ++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment (limited to 'doc') diff --git a/doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment b/doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment new file mode 100644 index 00000000..27aaf0cd --- /dev/null +++ b/doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment @@ -0,0 +1,43 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 2""" + date="2016-03-08T18:44:25Z" + content=""" +I've made a typed-os-requirements branch that has type-level +OS lists implemented. + +For example: + + *Propellor.Types.OS.TypeLevel> let l = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike + *Propellor.Types.OS.TypeLevel> l + OSList [OSDebian,OSFreeBSD] + *Propellor.Types.OS.TypeLevel> :t l + l :: OSList + (IntersectOSList + '[] '['OSDebian, 'OSFreeBSD] '['OSDebian, 'OSBuntish, 'OSFreeBSD]) + +What this is lacking is type-level equality for OSList. +The complicated type above should be equivilant to `OSList '[OSDebian, OSFreeBSD]` + +So, this doesn't type check yet: + + foo :: OSList '[OSDebian, OSFreeBSD] + foo = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike + + src/Propellor/Types/OS/Typelevel.hs:47:46: + Couldn't match expected type ‘IntersectOSList + '[] + '['OSDebian, 'OSFreeBSD] + '['OSDebian, 'OSBuntish, 'OSFreeBSD]’ + with actual type ‘'['OSDebian, 'OSFreeBSD]’ + In the expression: + (debian `combineSupportedOS` freeBSD) + `intersectSupportedOS` unixlike + In an equation for ‘foo’: + foo + = (debian `combineSupportedOS` freeBSD) + `intersectSupportedOS` unixlike + +Also, `intersectSupportedOS` should have an additional constraint, +to prevent it from generating an empty type-level list. +"""]] -- cgit v1.3-2-g0d8e From 61a1ba8ff1fa496af24d22986057a7607ae55ff1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Mar 2016 17:54:49 -0400 Subject: make it a type error to intersect two OS lists if the result is empty --- doc/todo/type_level_OS_requirements.mdwn | 4 +++- src/Propellor/Types/OS/Typelevel.hs | 15 +++++++++++---- 2 files changed, 14 insertions(+), 5 deletions(-) (limited to 'doc') diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn index 65e6099f..6d5d7aaf 100644 --- a/doc/todo/type_level_OS_requirements.mdwn +++ b/doc/todo/type_level_OS_requirements.mdwn @@ -11,7 +11,9 @@ For example, `Property i '[Debian, FreeBSD]` combined with `Property i '[Debian, yields a `Property i '[Debian]` -- the intersection of the OS's supported by the combined properties. -And, combining two properties that demand different OS's would need to be a +Combining two properties that demand different OS's would yield a +`Property i '[]` -- since the type level OS list is empty, + type error. Can a type level function combine two types successfully, and fail to combine two others somehow? Don't know. Maybe combine to an IncoherentOS and don't allow a `Property i IncoherentOS` to be used in a diff --git a/src/Propellor/Types/OS/Typelevel.hs b/src/Propellor/Types/OS/Typelevel.hs index 82f3a426..879259df 100644 --- a/src/Propellor/Types/OS/Typelevel.hs +++ b/src/Propellor/Types/OS/Typelevel.hs @@ -43,9 +43,8 @@ freeBSD = typeOS OSFreeBSD typeOS :: SupportedOS -> OSList os typeOS o = OSList [o] --- FIXME, should type check --- foo :: OSList '[OSDebian, OSFreeBSD] --- foo = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike +foo :: OSList '[OSDebian, OSFreeBSD] +foo = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike -- | Combines two lists of supported OS's, yielding a list with the -- contents of both. @@ -63,12 +62,20 @@ type instance ConcatOSList (a ': rest) list2 = a ': ConcatOSList rest list2 -- | The intersection between two lists of supported OS's. intersectSupportedOS - :: (r ~ IntersectOSList l1 l2) + :: (r ~ IntersectOSList l1 l2, CannotCombineOS l1 l2 r ~ CanCombineOS) => OSList l1 -> OSList l2 -> OSList r intersectSupportedOS (OSList l1) (OSList l2) = OSList (filter (`elem` l2) l1) +-- | Detect intersection of two lists that don't have any common OS. +-- +-- The name of this was chosen to make type errors a more understandable. +type family CannotCombineOS (list1 :: [a]) (list2 :: [a]) (listr :: [a]) :: CheckIntersection +type instance CannotCombineOS l1 l2 '[] = 'CannotCombineOS +type instance CannotCombineOS l1 l2 (a ': rest) = 'CanCombineOS +data CheckIntersection = CannotCombineOS | CanCombineOS + -- | Type level intersection for OSList type family IntersectOSList (list1 :: [a]) (list2 :: [a]) :: [a] type instance IntersectOSList '[] list2 = '[] -- cgit v1.3-2-g0d8e From 636c7cf5ba42d3636e06f298feae0b9219be6067 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 15:14:20 -0400 Subject: update docs for new property types --- doc/FreeBSD.mdwn | 6 ++++-- doc/Linux.mdwn | 2 +- doc/haskell_newbie.mdwn | 2 +- doc/writing_properties.mdwn | 10 +++++----- 4 files changed, 11 insertions(+), 9 deletions(-) (limited to 'doc') diff --git a/doc/FreeBSD.mdwn b/doc/FreeBSD.mdwn index 2edff223..47b9c65b 100644 --- a/doc/FreeBSD.mdwn +++ b/doc/FreeBSD.mdwn @@ -1,8 +1,10 @@ Propellor is in the early stages of supporting FreeBSD. It should basically work, and there are some modules with FreeBSD-specific properties. -However, many other properties assume they're being run on a -Debian Linux system, and need additional porting to support FreeBSD. +However, many other properties only work on a Debian Linux system, and need +additional porting to support FreeBSD. Such properties have types like +`Property DebianLike`. The type checker will detect and reject attempts +to combine such properties with `Property FreeBSD`. [Sample config file](http://git.joeyh.name/?p=propellor.git;a=blob;f=config-freebsd.hs) which configures a FreeBSD system, as well as a Linux one. diff --git a/doc/Linux.mdwn b/doc/Linux.mdwn index 0434d69d..00276f69 100644 --- a/doc/Linux.mdwn +++ b/doc/Linux.mdwn @@ -6,4 +6,4 @@ Indeed, Propellor has been ported to [[FreeBSD]] now! See [[forum/Supported_OS]] for porting tips. Note that you can run Propellor on a OSX laptop and have it manage Linux -systems. +and other systems. diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn index e92481f9..a150b202 100644 --- a/doc/haskell_newbie.mdwn +++ b/doc/haskell_newbie.mdwn @@ -96,7 +96,7 @@ is. 
 config.hs:30:19:
     Couldn't match expected type `RevertableProperty'
-                with actual type `Property NoInfo'
+                with actual type `Property DebianLike'
     In the return type of a call of `Apt.installed'
     In the second argument of `(!)', namely `Apt.installed ["ssh"]'
     In the first argument of `(&)', namely
diff --git a/doc/writing_properties.mdwn b/doc/writing_properties.mdwn
index 2209026f..1b7f046a 100644
--- a/doc/writing_properties.mdwn
+++ b/doc/writing_properties.mdwn
@@ -31,7 +31,7 @@ Propellor makes it very easy to put together a property like this.
 
 Let's start with a property that combines the two properties you mentioned:
 
-	hasLoginShell :: UserName -> FilePath -> Property
+	hasLoginShell :: UserName -> FilePath -> Property UnixLike
 	hasLoginShell user shell = shellSetTo user shell `requires` shellEnabled shell
 
 The shellEnabled property can be easily written using propellor's file
@@ -40,14 +40,14 @@ manipulation properties.
 	-- Need to add an import to the top of the source file.
 	import qualified Propellor.Property.File as File
 
-	shellEnabled :: FilePath -> Property
+	shellEnabled :: FilePath -> Property UnixLike
 	shellEnabled shell = "/etc/shells" `File.containsLine` shell
 
 And then, we want to actually change the user's shell. The `chsh(1)`
 program can do that, so we can simply tell propellor the command line to
 run:
 
-	shellSetTo :: UserName -> FilePath -> Property
+	shellSetTo :: UserName -> FilePath -> Property UnixLike
 	shellSetTo user shell = cmdProperty "chsh" ["--shell", shell, user]
 
 The only remaining problem with this is that shellSetTo runs chsh every
@@ -56,7 +56,7 @@ it runs, even when it didn't really do much. Now, there's an easy way to
 avoid that problem, we could just tell propellor to assume that chsh
 has not made a change:
 	
-	shellSetTo :: UserName -> FilePath -> Property
+	shellSetTo :: UserName -> FilePath -> Property UnixLike
 	shellSetTo user shell = cmdProperty "chsh" ["--shell", shell, user]
 		`assume` NoChange
 
@@ -64,7 +64,7 @@ But, it's not much harder to do this right. Let's make the property
 check if the user's shell is already set to the desired value and avoid
 doing anything in that case.
 
-	shellSetTo :: UserName -> FilePath -> Property
+	shellSetTo :: UserName -> FilePath -> Property UnixLike
 	shellSetTo user shell = check needchangeshell $
 		cmdProperty "chsh" ["--shell", shell, user]
 	  where
-- 
cgit v1.3-2-g0d8e


From e4ac94860bcc4511370e878e14ef9d45b60aeb2a Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Sat, 26 Mar 2016 15:35:55 -0400
Subject: remove `os` property

The new properties let the type checker know what the target OS is.
---
 config-freebsd.hs                |  7 +++---
 config-simple.hs                 |  2 +-
 debian/changelog                 |  2 ++
 doc/haskell_newbie.mdwn          |  4 ++--
 src/Propellor/Info.hs            | 51 ++++++++++++++++++++++++++++++++++------
 src/Propellor/Property/Chroot.hs |  2 +-
 src/Propellor/Property/OS.hs     |  2 +-
 7 files changed, 54 insertions(+), 16 deletions(-)

(limited to 'doc')

diff --git a/config-freebsd.hs b/config-freebsd.hs
index b6334c31..07aeb391 100644
--- a/config-freebsd.hs
+++ b/config-freebsd.hs
@@ -28,7 +28,7 @@ hosts =
 -- An example freebsd host.
 freebsdbox :: Host
 freebsdbox = host "freebsdbox.example.com"
-	& os (System (FreeBSD (FBSDProduction FBSD102)) "amd64")
+	& osFreeBSD (FBSDProduction FBSD102) "amd64"
 	& Pkg.update
 	& Pkg.upgrade
 	& Poudriere.poudriere poudriereZFS
@@ -44,7 +44,7 @@ poudriereZFS = Poudriere.defaultConfig
 -- An example linux host.
 linuxbox :: Host
 linuxbox = host "linuxbox.example.com"
-	& os (System (Debian Unstable) "amd64")
+	& osDebian Unstable "amd64"
 	& Apt.stdSourcesList
 	& Apt.unattendedUpgrades
 	& Apt.installed ["etckeeper"]
@@ -59,9 +59,8 @@ linuxbox = host "linuxbox.example.com"
 -- A generic webserver in a Docker container.
 webserverContainer :: Docker.Container
 webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
-	& os (System (Debian (Stable "jessie")) "amd64")
+	& osDebian (Stable "jessie") "amd64"
 	& Apt.stdSourcesList
 	& Docker.publish "80:80"
 	& Docker.volume "/var/www:/var/www"
 	& Apt.serviceInstalledRunning "apache2"
-
diff --git a/config-simple.hs b/config-simple.hs
index da1580c6..277e2edd 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -25,7 +25,7 @@ hosts =
 -- An example host.
 mybox :: Host
 mybox = host "mybox.example.com" $ props
-	& os (System (Debian Unstable) "amd64")
+	& osDebian Unstable "amd64"
 	& Apt.stdSourcesList
 	& Apt.unattendedUpgrades
 	& Apt.installed ["etckeeper"]
diff --git a/debian/changelog b/debian/changelog
index 562eccd7..df518753 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -10,6 +10,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       lists of properties. (If you have such a list, use `toProps`.)
     - And similarly, Chroot and Docker 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
diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn
index a150b202..bd343cd6 100644
--- a/doc/haskell_newbie.mdwn
+++ b/doc/haskell_newbie.mdwn
@@ -48,12 +48,12 @@ Finally, you need to define the configuration for each host in the list:
 [[!format haskell """
 mylaptop :: Host
 mylaptop = host "mylaptop.example.com"
-	& os (System (Debian Unstable) "amd64")
+	& osDebian Unstable "amd64"
 	& Apt.stdSourcesList
 
 myserver :: Host
 myserver = host "server.example.com"
-	& os (System (Debian (Stable "jessie")) "amd64")
+	& osDebian (Stable "jessie") "amd64"
 	& Apt.stdSourcesList
 	& Apt.installed ["ssh"]
 """]]
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 071bf4c2..725a02ad 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -1,6 +1,24 @@
 {-# LANGUAGE PackageImports #-}
 
-module Propellor.Info where
+module Propellor.Info (
+	osDebian,
+	osBuntish,
+	osFreeBSD,
+	pureInfoProperty,
+	pureInfoProperty',
+	askInfo,
+	getOS,
+	ipv4,
+	ipv6,
+	alias,
+	addDNS,
+	hostMap,
+	aliasMap,
+	findHost,
+	findHostNoAlias,
+	getAddresses,
+	hostAddresses,
+) where
 
 import Propellor.Types
 import Propellor.Types.Info
@@ -26,10 +44,32 @@ pureInfoProperty' desc i = addInfoProperty p i
 askInfo :: (IsInfo v) => Propellor v
 askInfo = asks (getInfo . 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.
+-- 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
+-- )
+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)
 
@@ -105,6 +145,3 @@ getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo
 
 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 }
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index bf6f2083..4480f98d 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -102,7 +102,7 @@ instance ChrootBootstrapper Debootstrapped where
 -- add the `os` property to specify the operating system to bootstrap.
 --
 -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
--- >	& os (System (Debian Unstable) "amd64")
+-- >	& osDebian Unstable "amd64"
 -- >	& Apt.installed ["ghc", "haskell-platform"]
 -- >	& ...
 debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index 42504453..72753248 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -46,7 +46,7 @@ import Control.Exception (throw)
 -- 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
-- 
cgit v1.3-2-g0d8e


From 36e97137e538de401bd0340b469e10dca5f4b475 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Sat, 26 Mar 2016 19:31:23 -0400
Subject: ported propagateContainer

Renamed several utility functions along the way.
---
 debian/changelog                         |  5 ++++
 doc/todo/type_level_OS_requirements.mdwn |  7 ++---
 propellor.cabal                          |  1 +
 src/Propellor/Container.hs               | 46 ++++++++++++++++++++++++++++++
 src/Propellor/Info.hs                    |  6 ++--
 src/Propellor/PrivData.hs                |  4 +--
 src/Propellor/PropAccum.hs               | 33 ----------------------
 src/Propellor/Property/Chroot.hs         | 43 +++++++++++++---------------
 src/Propellor/Property/Concurrent.hs     |  2 +-
 src/Propellor/Property/Conductor.hs      |  8 +++---
 src/Propellor/Property/Dns.hs            | 10 +++----
 src/Propellor/Property/Docker.hs         | 10 +++----
 src/Propellor/Property/List.hs           |  4 +--
 src/Propellor/Property/Partition.hs      |  2 +-
 src/Propellor/Property/Postfix.hs        |  2 +-
 src/Propellor/Property/Scheduled.hs      |  6 ++--
 src/Propellor/Property/Systemd.hs        | 18 ++++++------
 src/Propellor/Spin.hs                    |  4 +--
 src/Propellor/Types.hs                   | 48 +++++++++++++-------------------
 src/Propellor/Types/Info.hs              |  6 ++--
 20 files changed, 134 insertions(+), 131 deletions(-)
 create mode 100644 src/Propellor/Container.hs

(limited to 'doc')

diff --git a/debian/changelog b/debian/changelog
index df518753..8a5b67e4 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -49,6 +49,11 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       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
     what to do based on the Host's OS.
diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn
index 7c2fb78f..f1c3e59f 100644
--- a/doc/todo/type_level_OS_requirements.mdwn
+++ b/doc/todo/type_level_OS_requirements.mdwn
@@ -21,13 +21,12 @@ withOS.
 
 The `os` property would need to yield a `Property (os:[])`, where the type
 level list contains a type-level eqivilant of the value passed to the
-property. Is that possible to do? reification or something?
-(See: )
-Or, alternatively, could have less polymorphic `debian` etc
+property. Is that possible to do?
+Or, alternatively, could have less polymorphic `osDebian` etc
 properties replace the `os` property.
 
 If a Host's list of properties, when all combined together,
-contains more than one element in its '[OS], that needs to be a type error,
+contains more than one element in its '[OS], that could be a type error,
 the OS of the Host is indeterminite. Which would be fixed by using the `os`
 property to specify.
 
diff --git a/propellor.cabal b/propellor.cabal
index e47bb2e6..4a7739d3 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -141,6 +141,7 @@ Library
     Propellor.PropAccum
     Propellor.Utilities
     Propellor.CmdLine
+    Propellor.Container
     Propellor.Info
     Propellor.Message
     Propellor.Debug
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
new file mode 100644
index 00000000..6e974efd
--- /dev/null
+++ b/src/Propellor/Container.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE DataKinds, TypeFamilies #-}
+
+module Propellor.Container where
+
+import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Types.Info
+import Propellor.PrivData
+
+class Container c where
+	containerProperties :: c -> [ChildProperty]
+	containerInfo :: c -> Info
+
+instance Container Host where
+	 containerProperties = hostProperties
+	 containerInfo = hostInfo
+
+-- | 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
+		, Container 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
+		    	`addInfoProperty` mapInfo (forceHostContext containername)
+				(propagatableInfo (getInfo p))
+		   	`addChildren` map convert (getChildren p)
+		in toChildProperty n'
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 725a02ad..ff0b3b5e 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -42,7 +42,7 @@ pureInfoProperty' desc i = addInfoProperty p i
 
 -- | Gets a value from the host's Info.
 askInfo :: (IsInfo v) => Propellor v
-askInfo = asks (getInfo . hostInfo)
+askInfo = asks (fromInfo . hostInfo)
 
 -- | Specifies that a host's operating system is Debian,
 -- and further indicates the suite and architecture.
@@ -129,7 +129,7 @@ hostMap l = M.fromList $ zip (map hostName l) l
 
 aliasMap :: [Host] -> M.Map HostName Host
 aliasMap = M.fromList . concat .
-	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ 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)
@@ -141,7 +141,7 @@ findAlias :: [Host] -> HostName -> Maybe Host
 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)
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 77c7133f..0bc0c100 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -161,7 +161,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap
 filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
   where
 	used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
-		fromPrivInfo $ getInfo $ hostInfo host
+		fromPrivInfo $ fromInfo $ hostInfo host
 
 getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
 getPrivData field context m = do
@@ -245,7 +245,7 @@ mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h
 mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a
 mkPrivDataMap host mkv = M.fromList $
 	map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d))
-		(S.toList $ fromPrivInfo $ getInfo $ hostInfo host)
+		(S.toList $ fromPrivInfo $ fromInfo $ hostInfo host)
 
 setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
 setPrivDataTo field context (PrivData value) = do
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 8281b9a1..af362ca7 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -12,7 +12,6 @@ module Propellor.PropAccum
 	, (&)
 	, (&^)
 	, (!)
-	--, propagateContainer
 	) where
 
 import Propellor.Types
@@ -82,35 +81,3 @@ Props c &^ p = Props (toChildProperty p : c)
 	-> 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 metatypes
-	-> Property metatypes
-propagateContainer containername c prop = Property
-	undefined
-	(propertyDesc prop)
-	(getSatisfy 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) (getSatisfy p) i cs
-
--}
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 4480f98d..547e5c94 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -41,23 +41,18 @@ data Chroot where
 	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
 
 chrootSystem :: Chroot -> Maybe System
-chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
+chrootSystem (Chroot _ _ h) = fromInfoVal (fromInfo (hostInfo h))
 
 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 (HasInfo + UnixLike))
 
 -- | Use this to bootstrap a chroot by extracting a tarball.
 --
@@ -70,12 +65,11 @@ data ChrootTarball = ChrootTarball FilePath
 instance ChrootBootstrapper ChrootTarball where
 	buildchroot (ChrootTarball tb) _ loc = Right $ 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,14 +86,15 @@ instance ChrootBootstrapper Debootstrapped where
 		(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"
 -- >	& osDebian Unstable "amd64"
@@ -131,25 +126,25 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
 	(propertyList (chrootDesc c "removed") [teardown])
   where
 	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 = check (not <$> unpopulated loc) $
 		property ("removed " ++ loc) $
 			makeChange (removeChroot loc)
 
-propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
+propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property (HasInfo + UnixLike)
 propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
   where
 	p' = infoProperty
-		(propertyDesc p)
+		(getDesc p)
 		(getSatisfy p)
-		(propertyInfo p <> chrootInfo c)
+		(getInfo p <> chrootInfo c)
 		(propertyChildren p)
 
 chrootInfo :: Chroot -> Info
@@ -157,7 +152,7 @@ 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 +200,7 @@ chain :: [Host] -> CmdLine -> IO ()
 chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 	case findHostNoAlias hostlist hn of
 		Nothing -> errorMessage ("cannot find host " ++ hn)
-		Just parenthost -> case M.lookup loc (_chroots $ 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
@@ -215,7 +210,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 		onlyProcess (provisioningLock loc) $ do
 			r <- runPropellor (setInChroot h) $ ensureChildProperties $
 				if systemdonly
-					then [toProp Systemd.installed]
+					then [toChildProperty Systemd.installed]
 					else hostProperties h
 			flushConcurrentOutput
 			putStrLn $ "\n" ++ show r
@@ -257,7 +252,7 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
 -- This is accomplished by installing a  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
+noServices :: RevertableProperty DebianLike DebianLike
 noServices = setup  teardown
   where
 	f = "/usr/sbin/policy-rc.d"
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index a86c839f..ace85a3c 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -78,7 +78,7 @@ concurrently p1 p2 = (combineWith go go p1 p2)
 -- The above example will run foo and bar concurrently, and once either of
 -- those 2 properties finishes, will start running baz.
 concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
-concurrentList getn d (Props ps) = property d go `modifyChildren` (++ ps)
+concurrentList getn d (Props ps) = property d go `addChildren` ps
   where
 	go = do
 		n <- liftIO getn
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index ec15281b..8fe607bc 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -126,7 +126,7 @@ mkOrchestra = fromJust . go S.empty
   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,7 +214,7 @@ orchestrate :: [Host] -> [Host]
 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
 
@@ -222,7 +222,7 @@ orchestrate hs = map go hs
 	removeold' h oldconductor = addPropHost h $
 		undoRevertableProperty $ 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
@@ -299,7 +299,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
 	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 DebianLike UnixLike
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index a660a016..2b5596bd 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -213,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
 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
@@ -468,7 +468,7 @@ genZone inzdomain hostmap zdomain soa =
 	-- 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
@@ -483,7 +483,7 @@ genZone inzdomain hostmap zdomain soa =
 	  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
@@ -518,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf)
 	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.
@@ -531,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
 	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
 
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index d19d15aa..fe1e3b18 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -172,9 +172,9 @@ propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Pr
 propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
   where
 	p' = infoProperty
-		(propertyDesc p)
+		(getDesc p)
 		(getSatisfy p)
-		(propertyInfo p <> dockerinfo)
+		(getInfo p <> dockerinfo)
 		(propertyChildren p)
 	dockerinfo = dockerInfo $
 		mempty { _dockerContainers = M.singleton cn h }
@@ -186,7 +186,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
   where
 	runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
 		(_dockerRunParams info)
-	info = getInfo $ hostInfo h'
+	info = fromInfo $ hostInfo h'
 	h' = h
 		-- Restart by default so container comes up on
 		-- boot or when docker is upgraded.
@@ -435,7 +435,7 @@ myContainerSuffix = ".propellor"
 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 Linux
 runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
@@ -574,7 +574,7 @@ chain hostlist hn s = case toContainerId s of
 	Nothing -> errorMessage "bad container id"
 	Just cid -> case findHostNoAlias hostlist hn of
 		Nothing -> errorMessage ("cannot find host " ++ hn)
-		Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ 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
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 304d0863..a8b8347a 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -35,7 +35,7 @@ toProps ps = Props (map toChildProperty ps)
 propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
 propertyList desc (Props ps) = 
 	property desc (ensureChildProperties cs)
-		`modifyChildren` (++ cs)
+		`addChildren` cs
   where
 	cs = map toChildProperty ps
 
@@ -44,7 +44,7 @@ propertyList desc (Props ps) =
 combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
 combineProperties desc (Props ps) = 
 	property desc (combineSatisfy cs NoChange)
-		`modifyChildren` (++ cs)
+		`addChildren` cs
   where
 	cs = map toChildProperty ps
 
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 5aff4ba4..291d4168 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -68,7 +68,7 @@ kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
 kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
   where
 	go :: Property DebianLike
-	go = property' (propertyDesc (mkprop [])) $ \w -> do
+	go = property' (getDesc (mkprop [])) $ \w -> do
 		cleanup -- idempotency
 		loopdevs <- liftIO $ kpartxParse
 			<$> readProcess "kpartx" ["-avs", diskimage]
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 7d9e7068..45aa4e42 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -304,7 +304,7 @@ saslAuthdInstalled = setupdaemon
 -- | 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 ->
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index 534e1e88..95e4e362 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -22,18 +22,18 @@ import qualified Data.Map as M
 -- last run.
 period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
 period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
-	lasttime <- liftIO $ getLastChecked (propertyDesc prop)
+	lasttime <- liftIO $ getLastChecked (getDesc prop)
 	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
 	t <- liftIO localNow
 	if Just t >= nexttime
 		then do
 			r <- satisfy
-			liftIO $ setLastChecked t (propertyDesc prop)
+			liftIO $ setLastChecked t (getDesc prop)
 			return r
 		else noChange
   where
 	schedule = Schedule recurrance AnyTime
-	desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
+	desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
 
 -- | Like period, but parse a human-friendly string.
 periodParse :: (IsProp (Property i)) => Property i -> String -> Property i
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 2234ad5c..d909e4df 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -214,13 +214,13 @@ container name system mkchroot = Container name c h
 --
 -- Reverting this property stops the container, removes the systemd unit,
 -- and deletes the chroot and all its contents.
-nspawned :: Container -> RevertableProperty HasInfo
+nspawned :: Container -> RevertableProperty (HasInfo + UnixLike) UnixLike
 nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
 	p `describe` ("nspawned " ++ name)
   where
 	p = enterScript c
 		`before` chrootprovisioned
-		`before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h)
+		`before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h)
 		`before` containerprovisioned
 
 	-- Chroot provisioning is run in systemd-only mode,
@@ -336,7 +336,7 @@ mungename = replace "/" "_"
 -- When there is no leading dash, "--" is prepended to the parameter.
 --
 -- Reverting the property will remove a parameter, if it's present.
-containerCfg :: String -> RevertableProperty HasInfo
+containerCfg :: String -> RevertableProperty (HasInfo + UnixLike) UnixLike
 containerCfg p = RevertableProperty (mk True) (mk False)
   where
 	mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $
@@ -348,18 +348,18 @@ containerCfg p = RevertableProperty (mk True) (mk False)
 -- | Bind mounts  from the host into the container.
 --
 -- This property is enabled by default. Revert it to disable it.
-resolvConfed :: RevertableProperty HasInfo
+resolvConfed :: RevertableProperty (HasInfo + UnixLike) UnixLike
 resolvConfed = containerCfg "bind=/etc/resolv.conf"
 
 -- | Link the container's journal to the host's if possible.
 -- (Only works if the host has persistent journal enabled.)
 --
 -- This property is enabled by default. Revert it to disable it.
-linkJournal :: RevertableProperty HasInfo
+linkJournal :: RevertableProperty (HasInfo + UnixLike) UnixLike
 linkJournal = containerCfg "link-journal=try-guest"
 
 -- | Disconnect networking of the container from the host.
-privateNetwork :: RevertableProperty HasInfo
+privateNetwork :: RevertableProperty (HasInfo + UnixLike) UnixLike
 privateNetwork = containerCfg "private-network"
 
 class Publishable a where
@@ -397,7 +397,7 @@ instance Publishable (Proto, Bound Port) where
 -- >	& Systemd.running Systemd.networkd
 -- >	& Systemd.publish (Port 80 ->- Port 8080)
 -- >	& Apt.installedRunning "apache2"
-publish :: Publishable p => p -> RevertableProperty HasInfo
+publish :: Publishable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike
 publish p = containerCfg $ "--port=" ++ toPublish p
 
 class Bindable a where
@@ -410,9 +410,9 @@ instance Bindable (Bound FilePath) where
 	toBind v = hostSide v ++ ":" ++ containerSide v
 
 -- | Bind mount a file or directory from the host into the container.
-bind :: Bindable p => p -> RevertableProperty HasInfo
+bind :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike
 bind p = containerCfg $ "--bind=" ++ toBind p
 
 -- | Read-only mind mount.
-bindRo :: Bindable p => p -> RevertableProperty HasInfo
+bindRo :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike
 bindRo p = containerCfg $ "--bind-ro=" ++ toBind p
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 5f103b8a..944696dd 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -90,7 +90,7 @@ spin' mprivdata relay target hst = do
 		error "remote propellor failed"
   where
 	hn = fromMaybe target relay
-	sys = case getInfo (hostInfo hst) of
+	sys = case fromInfo (hostInfo hst) of
 		InfoVal o -> Just o
 		NoInfoVal -> Nothing
 
@@ -170,7 +170,7 @@ getSshTarget target hst
 					return ip
 
 	configips = map fromIPAddr $ mapMaybe getIPAddr $
-		S.toList $ fromDnsInfo $ getInfo $ hostInfo hst
+		S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
 
 -- Update the privdata, repo url, and git repo over the ssh
 -- connection, talking to the user's local propellor instance which is
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index ccbfd3e0..2bddfc1a 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -26,11 +26,7 @@ module Propellor.Types
 	, type (+)
 	, addInfoProperty
 	, addInfoProperty'
-	, addChildrenProperty
 	, adjustPropertySatisfy
-	, propertyInfo
-	, propertyDesc
-	, propertyChildren
 	, RevertableProperty(..)
 	, ()
 	, ChildProperty
@@ -124,12 +120,15 @@ type Desc = String
 -- internally, so you needn't worry about them.
 data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]
 
+instance Show (Property metatypes) where
+	show p = "property " ++ show (getDesc p)
+
 -- | Since there are many different types of Properties, they cannot be put
 -- into a list. The simplified ChildProperty can be put into a list.
 data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
 
 instance Show ChildProperty where
-	show (ChildProperty desc _ _ _) = desc
+	show = getDesc
 
 -- | Constructs a Property, from a description and an action to run to
 -- ensure the Property is met.
@@ -170,28 +169,10 @@ addInfoProperty'
 addInfoProperty' (Property t d a oldi c) newi =
 	Property t d a (oldi <> newi) c
 
--- | Adds children to a Property.
-addChildrenProperty :: Property metatypes -> [ChildProperty] -> Property metatypes
-addChildrenProperty (Property t s a i cs) cs' = Property t s a i (cs ++ cs')
-
 -- | Changes the action that is performed to satisfy a property.
 adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
 adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c
 
-propertyInfo :: Property metatypes -> Info
-propertyInfo (Property _ _ _ i _) = i
-
-propertyDesc :: Property metatypes -> Desc
-propertyDesc (Property _ d _ _ _) = d
-
-instance Show (Property metatypes) where
-	show p = "property " ++ show (propertyDesc p)
-
--- | A Property can include a list of child properties that it also
--- satisfies. This allows them to be introspected to collect their info, etc.
-propertyChildren :: Property metatypes -> [ChildProperty]
-propertyChildren (Property _ _ _ _ c) = c
-
 -- | A property that can be reverted. The first Property is run
 -- normally and the second is run when it's reverted.
 data RevertableProperty setupmetatypes undometatypes = RevertableProperty
@@ -209,14 +190,16 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where
 	-> RevertableProperty setupmetatypes undometatypes
 setup  undo = RevertableProperty setup undo
 
--- | Class of types that can be used as properties of a host.
 class IsProp p where
 	setDesc :: p -> Desc -> p
 	getDesc :: p -> Desc
-	modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p
+	getChildren :: p -> [ChildProperty]
+	addChildren :: p -> [ChildProperty] -> p
 	-- | Gets the info of the property, combined with all info
 	-- of all children properties.
 	getInfoRecursive :: p -> Info
+	-- | Info, not including info from children.
+	getInfo :: p -> Info
 	-- | Gets a ChildProperty representing the Property.
 	-- You should not normally need to use this.
 	toChildProperty :: p -> ChildProperty
@@ -227,19 +210,23 @@ class IsProp p where
 
 instance IsProp (Property metatypes) where
 	setDesc (Property t _ a i c) d = Property t d a i c
-	getDesc = propertyDesc
-	modifyChildren (Property t d a i c) f = Property t d a i (f c)
+	getDesc (Property _ d _ _ _) = d
+	getChildren (Property _ _ _ _ c) = c
+	addChildren (Property t d a i c) c' = Property t d a i (c ++ c')
 	getInfoRecursive (Property _ _ _ i c) =
 		i <> mconcat (map getInfoRecursive c)
+	getInfo (Property _ _ _ i _) = i
 	toChildProperty (Property _ d a i c) = ChildProperty d a i c
 	getSatisfy (Property _ _ a _ _) = a
 
 instance IsProp ChildProperty where
 	setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
 	getDesc (ChildProperty d _ _ _) = d
-	modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c)
+	getChildren (ChildProperty _ _ _ c) = c
+	addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c')
 	getInfoRecursive (ChildProperty _ _ i c) =
 		i <> mconcat (map getInfoRecursive c)
+	getInfo (ChildProperty _ _ i _) = i
 	toChildProperty = id
 	getSatisfy (ChildProperty _ a _ _) = a
 
@@ -248,9 +235,12 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where
 	setDesc (RevertableProperty p1 p2) d =
 		RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
 	getDesc (RevertableProperty p1 _) = getDesc p1
-	modifyChildren (RevertableProperty p1 p2) f = RevertableProperty (modifyChildren p1 f) (modifyChildren p2 f)
+	getChildren (RevertableProperty p1 _) = getChildren p1
+	-- | Only add children to the active side.
+	addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2
 	-- | Return the Info of the currently active side.
 	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
+	getInfo (RevertableProperty p1 _p2) = getInfo p1
 	toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1
 	getSatisfy (RevertableProperty p1 _) = getSatisfy p1
 
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index bc1543e2..c7f6b82f 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -5,7 +5,7 @@ module Propellor.Types.Info (
 	IsInfo(..),
 	addInfo,
 	toInfo,
-	getInfo,
+	fromInfo,
 	mapInfo,
 	propagatableInfo,
 	InfoVal(..),
@@ -51,8 +51,8 @@ toInfo :: IsInfo v => v -> Info
 toInfo = addInfo mempty
 
 -- The list is reversed here because addInfo builds it up in reverse order.
-getInfo :: IsInfo v => Info -> v
-getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
+fromInfo :: IsInfo v => Info -> v
+fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
 
 -- | Maps a function over all values stored in the Info that are of the
 -- appropriate type.
-- 
cgit v1.3-2-g0d8e


From af7b2d61c0c7f9b4fe53d8f5d18b5426a93cbd7b Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Sun, 27 Mar 2016 22:10:48 -0400
Subject: add dep on concurrent-output, and re-enable -O0

Using the external concurrent-output library lets it be built with -O2 as
is needed to get good runtime memory use.

Enabling -O0 because ghc is using rather a lot more time and memory due to
the new more complex types.

old master branch:

Linking dist/build/propellor-config/propellor-config ...
24.59user 0.97system 0:25.93elapsed 98%CPU (0avgtext+0avgdata 354612maxresident)k
1544inputs+46064outputs (0major+371244minor)pagefaults 0swaps

this branch before -O0:

Linking dist/build/propellor-config/propellor-config ...
25.56user 0.73system 0:26.61elapsed 98%CPU (0avgtext+0avgdata 345348maxresident)k
0inputs+43480outputs (0major+364163minor)pagefaults 0swaps

this branch with -O0:

Linking dist/build/propellor-config/propellor-config ...
11.91user 0.75system 0:12.97elapsed 97%CPU (0avgtext+0avgdata 237472maxresident)k
16inputs+37264outputs (0major+336166minor)pagefaults 0swaps

Above benchmarks are building all source files needed by config-simple.hs.
The story is rather worse for joeyconfig.hs; building it now needs over 500 mb
even with -O0 :-/
---
 debian/changelog                          |   3 +
 debian/control                            |   2 +
 doc/todo/depend_on_concurrent-output.mdwn |   3 +
 propellor.cabal                           |  34 +-
 src/Propellor/Bootstrap.hs                |   1 +
 src/System/Console/Concurrent.hs          |  44 ---
 src/System/Console/Concurrent/Internal.hs | 556 ------------------------------
 src/System/Process/Concurrent.hs          |  34 --
 8 files changed, 27 insertions(+), 650 deletions(-)
 delete mode 100644 src/System/Console/Concurrent.hs
 delete mode 100644 src/System/Console/Concurrent/Internal.hs
 delete mode 100644 src/System/Process/Concurrent.hs

(limited to 'doc')

diff --git a/debian/changelog b/debian/changelog
index af2f5c2b..036b8f34 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -57,6 +57,9 @@ propellor (3.0.0) UNRELEASED; urgency=medium
   * The new `pickOS` property combinator can be used to combine different
     properties, supporting different OS's, into one Property that chooses
     what to do 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.
 
  -- Joey Hess   Thu, 24 Mar 2016 15:02:33 -0400
 
diff --git a/debian/control b/debian/control
index 757462d1..898e558d 100644
--- a/debian/control
+++ b/debian/control
@@ -18,6 +18,7 @@ Build-Depends:
 	libghc-exceptions-dev (>= 0.6),
 	libghc-stm-dev,
 	libghc-text-dev,
+	libghc-concurrent-output-dev,
 Maintainer: Joey Hess 
 Standards-Version: 3.9.6
 Vcs-Git: git://git.joeyh.name/propellor
@@ -41,6 +42,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
 	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
diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn
index fdc66b04..a104c82b 100644
--- a/doc/todo/depend_on_concurrent-output.mdwn
+++ b/doc/todo/depend_on_concurrent-output.mdwn
@@ -8,3 +8,6 @@ Once this is done, can switch GHC-Options back to -O0 from -O.
 -O0 is better because ghc takes less memory to build propellor.
 
 [[!tag user/joey]]
+
+> [[done]]. Didn't wait for it to hit stable; cabal will be used to install
+> it.
diff --git a/propellor.cabal b/propellor.cabal
index e946f697..06142155 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -36,34 +36,39 @@ Description:
 
 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
@@ -201,9 +206,6 @@ Library
     Utility.ThreadScheduler
     Utility.Tmp
     Utility.UserInfo
-    System.Console.Concurrent
-    System.Console.Concurrent.Internal
-    System.Process.Concurrent
 
 source-repository head
   type: git
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 69eee66c..3b4c3106 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -90,6 +90,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
 		, "libghc-exceptions-dev"
 		, "libghc-stm-dev"
 		, "libghc-text-dev"
+		, "libghc-concurrent-output-dev"
 		, "make"
 		]
 	fbsddeps =
diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs
deleted file mode 100644
index 12447637..00000000
--- a/src/System/Console/Concurrent.hs
+++ /dev/null
@@ -1,44 +0,0 @@
--- | 
--- Copyright: 2015 Joey Hess 
--- License: BSD-2-clause
--- 
--- Concurrent output handling.
---
--- > import Control.Concurrent.Async
--- > import System.Console.Concurrent
--- >
--- > main = withConcurrentOutput $
--- > 	outputConcurrent "washed the car\n"
--- > 		`concurrently`
--- >	outputConcurrent "walked the dog\n"
--- >		`concurrently`
--- > 	createProcessConcurrent (proc "ls" [])
-
-{-# LANGUAGE CPP #-}
-
-module System.Console.Concurrent (
-	-- * Concurrent output
-	withConcurrentOutput,
-	Outputable(..),
-	outputConcurrent,
-	errorConcurrent,
-	ConcurrentProcessHandle,
-#ifndef mingw32_HOST_OS
-	createProcessConcurrent,
-#endif
-	waitForProcessConcurrent,
-	createProcessForeground,
-	flushConcurrentOutput,
-	lockOutput,
-	-- * Low level access to the output buffer
-	OutputBuffer,
-	StdHandle(..),
-	bufferOutputSTM,
-	outputBufferWaiterSTM,
-	waitAnyBuffer,
-	waitCompleteLines,
-	emitOutputBuffer,
-) where
-
-import System.Console.Concurrent.Internal
-
diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs
deleted file mode 100644
index 5b9cf454..00000000
--- a/src/System/Console/Concurrent/Internal.hs
+++ /dev/null
@@ -1,556 +0,0 @@
-{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
-{-# LANGUAGE CPP #-}
-
--- | 
--- Copyright: 2015 Joey Hess 
--- License: BSD-2-clause
--- 
--- Concurrent output handling, internals.
---
--- May change at any time.
-
-module System.Console.Concurrent.Internal where
-
-import System.IO
-#ifndef mingw32_HOST_OS
-import System.Posix.IO
-#endif
-import System.Directory
-import System.Exit
-import Control.Monad
-import Control.Monad.IO.Class (liftIO, MonadIO)
-import System.IO.Unsafe (unsafePerformIO)
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Concurrent.Async
-import Data.Maybe
-import Data.List
-import Data.Monoid
-import qualified System.Process as P
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Control.Applicative
-import Prelude
-import System.Log.Logger
-
-import Utility.Monad
-import Utility.Exception
-
-data OutputHandle = OutputHandle
-	{ outputLock :: TMVar Lock
-	, outputBuffer :: TMVar OutputBuffer
-	, errorBuffer :: TMVar OutputBuffer
-	, outputThreads :: TMVar Integer
-	, processWaiters :: TMVar [Async ()]
-	, waitForProcessLock :: TMVar ()
-	}
-
-data Lock = Locked
-
--- | A shared global variable for the OutputHandle.
-{-# NOINLINE globalOutputHandle #-}
-globalOutputHandle :: OutputHandle
-globalOutputHandle = unsafePerformIO $ OutputHandle
-	<$> newEmptyTMVarIO
-	<*> newTMVarIO (OutputBuffer [])
-	<*> newTMVarIO (OutputBuffer [])
-	<*> newTMVarIO 0
-	<*> newTMVarIO []
-	<*> newEmptyTMVarIO
-
--- | Holds a lock while performing an action. This allows the action to
--- perform its own output to the console, without using functions from this
--- module.
---
--- While this is running, other threads that try to lockOutput will block.
--- Any calls to `outputConcurrent` and `createProcessConcurrent` will not
--- block, but the output will be buffered and displayed only once the
--- action is done.
-lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
-lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock)
-
--- | Blocks until we have the output lock.
-takeOutputLock :: IO ()
-takeOutputLock = void $ takeOutputLock' True
-
--- | Tries to take the output lock, without blocking.
-tryTakeOutputLock :: IO Bool
-tryTakeOutputLock = takeOutputLock' False
-
-withLock :: (TMVar Lock -> STM a) -> IO a
-withLock a = atomically $ a (outputLock globalOutputHandle)
-
-takeOutputLock' :: Bool -> IO Bool
-takeOutputLock' block = do
-	locked <- withLock $ \l -> do
-		v <- tryTakeTMVar l
-		case v of
-			Just Locked
-				| block -> retry
-				| otherwise -> do
-					-- Restore value we took.
-					putTMVar l Locked
-					return False
-			Nothing -> do
-				putTMVar l Locked
-				return True
-	when locked $ do
-		(outbuf, errbuf) <- atomically $ (,)
-			<$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer [])
-			<*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer [])
-		emitOutputBuffer StdOut outbuf
-		emitOutputBuffer StdErr errbuf
-	return locked
-
--- | Only safe to call after taking the output lock.
-dropOutputLock :: IO ()
-dropOutputLock = withLock $ void . takeTMVar
-
--- | Use this around any actions that use `outputConcurrent`
--- or `createProcessConcurrent`
---
--- This is necessary to ensure that buffered concurrent output actually
--- gets displayed before the program exits.
-withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a
-withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput
-
--- | Blocks until any processes started by `createProcessConcurrent` have
--- finished, and any buffered output is displayed. Also blocks while
--- `lockOutput` is is use.
---
--- `withConcurrentOutput` calls this at the end, so you do not normally
--- need to use this.
-flushConcurrentOutput :: IO ()
-flushConcurrentOutput = do
-	atomically $ do
-		r <- takeTMVar (outputThreads globalOutputHandle)
-		if r <= 0
-			then putTMVar (outputThreads globalOutputHandle) r
-			else retry
-	-- Take output lock to wait for anything else that might be
-	-- currently generating output.
-	lockOutput $ return ()
-
--- | Values that can be output.
-class Outputable v where
-	toOutput :: v -> T.Text
-
-instance Outputable T.Text where
-	toOutput = id
-
-instance Outputable String where
-	toOutput = toOutput . T.pack
-
--- | Displays a value to stdout.
---
--- No newline is appended to the value, so if you want a newline, be sure
--- to include it yourself.
---
--- Uses locking to ensure that the whole output occurs atomically
--- even when other threads are concurrently generating output.
---
--- When something else is writing to the console at the same time, this does
--- not block. It buffers the value, so it will be displayed once the other
--- writer is done.
-outputConcurrent :: Outputable v => v -> IO ()
-outputConcurrent = outputConcurrent' StdOut
-
--- | Like `outputConcurrent`, but displays to stderr.
---
--- (Does not throw an exception.)
-errorConcurrent :: Outputable v => v -> IO ()
-errorConcurrent = outputConcurrent' StdErr
-
-outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()
-outputConcurrent' stdh v = bracket setup cleanup go
-  where
-	setup = tryTakeOutputLock
-	cleanup False = return ()
-	cleanup True = dropOutputLock
-	go True = do
-		T.hPutStr h (toOutput v)
-		hFlush h
-	go False = do
-		oldbuf <- atomically $ takeTMVar bv
-		newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf
-		atomically $ putTMVar bv newbuf
-	h = toHandle stdh
-	bv = bufferFor stdh
-
-newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle
-
-toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h)
-
--- | Use this to wait for processes started with 
--- `createProcessConcurrent` and `createProcessForeground`, and get their
--- exit status.
---
--- Note that such processes are actually automatically waited for
--- internally, so not calling this explicitly will not result
--- in zombie processes. This behavior differs from `P.waitForProcess`
-waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
-waitForProcessConcurrent (ConcurrentProcessHandle h) = 
-	bracket lock unlock checkexit
-  where
-	lck = waitForProcessLock globalOutputHandle
-	lock = atomically $ tryPutTMVar lck ()
-	unlock True = atomically $ takeTMVar lck
-	unlock False = return ()
-	checkexit locked = maybe (waitsome locked) return
-		=<< P.getProcessExitCode h
-	waitsome True = do
-		let v = processWaiters globalOutputHandle
-		l <- atomically $ readTMVar v
-		if null l
-			-- Avoid waitAny [] which blocks forever
-			then P.waitForProcess h
-			else do
-				-- Wait for any of the running
-				-- processes to exit. It may or may not
-				-- be the one corresponding to the
-				-- ProcessHandle. If it is,
-				-- getProcessExitCode will succeed.
-				void $ tryIO $ waitAny l
-				checkexit True
-	waitsome False = do
-		-- Another thread took the lck first. Wait for that thread to
-		-- wait for one of the running processes to exit.
-		atomically $ do
-			putTMVar lck ()
-			takeTMVar lck
-		checkexit False
-
--- Registers an action that waits for a process to exit,
--- adding it to the processWaiters list, and removing it once the action
--- completes.
-asyncProcessWaiter :: IO () -> IO ()
-asyncProcessWaiter waitaction = do
-	regdone <- newEmptyTMVarIO
-	waiter <- async $ do
-		self <- atomically (takeTMVar regdone)
-		waitaction `finally` unregister self
-	register waiter regdone
-  where
-	v = processWaiters globalOutputHandle
-  	register waiter regdone = atomically $ do
-		l <- takeTMVar v
-		putTMVar v (waiter:l)
-		putTMVar regdone waiter
-	unregister waiter = atomically $ do
-		l <- takeTMVar v
-		putTMVar v (filter (/= waiter) l)
-
--- | Wrapper around `System.Process.createProcess` that prevents 
--- multiple processes that are running concurrently from writing
--- to stdout/stderr at the same time.
---
--- If the process does not output to stdout or stderr, it's run
--- by createProcess entirely as usual. Only processes that can generate
--- output are handled specially:
---
--- A process is allowed to write to stdout and stderr in the usual
--- way, assuming it can successfully take the output lock.
---
--- When the output lock is held (ie, by another concurrent process,
--- or because `outputConcurrent` is being called at the same time),
--- the process is instead run with its stdout and stderr
--- redirected to a buffer. The buffered output will be displayed as soon
--- as the output lock becomes free.
---
--- Currently only available on Unix systems, not Windows.
-#ifndef mingw32_HOST_OS
-createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) 
-createProcessConcurrent p
-	| willOutput (P.std_out p) || willOutput (P.std_err p) =
-		ifM tryTakeOutputLock
-			( fgProcess p
-			, bgProcess p
-			)
-	| otherwise = do
-		r@(_, _, _, h) <- P.createProcess p
-		asyncProcessWaiter $
-			void $ tryIO $ P.waitForProcess h
-		return (toConcurrentProcessHandle r)
-#endif
-
--- | Wrapper around `System.Process.createProcess` that makes sure a process
--- is run in the foreground, with direct access to stdout and stderr.
--- Useful when eg, running an interactive process.
-createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-createProcessForeground p = do
-	takeOutputLock
-	fgProcess p
-
-fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-fgProcess p = do
-	r@(_, _, _, h) <- P.createProcess p
-		`onException` dropOutputLock
-	registerOutputThread
-	debug ["fgProcess", showProc p]
-	-- Wait for the process to exit and drop the lock.
-	asyncProcessWaiter $ do
-		void $ tryIO $ P.waitForProcess h
-		unregisterOutputThread
-		dropOutputLock
-		debug ["fgProcess done", showProc p]
-	return (toConcurrentProcessHandle r)
-	
-debug :: [String] -> IO ()
-debug = debugM "concurrent-output" . unwords
-
-showProc :: P.CreateProcess -> String
-showProc = go . P.cmdspec
-  where
-	go (P.ShellCommand s) = s
-	go (P.RawCommand c ps) = show (c, ps)
-
-#ifndef mingw32_HOST_OS
-bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-bgProcess p = do
-	(toouth, fromouth) <- pipe
-	(toerrh, fromerrh) <- pipe
-	debug ["bgProcess", showProc p]
-	let p' = p
-		{ P.std_out = rediroutput (P.std_out p) toouth
-		, P.std_err = rediroutput (P.std_err p) toerrh
-		}
-	registerOutputThread
-	r@(_, _, _, h) <- P.createProcess p'
-		`onException` unregisterOutputThread
-	asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h
-	outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth
-	errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh
-	void $ async $ bufferWriter [outbuf, errbuf]
-	return (toConcurrentProcessHandle r)
-  where
-	pipe = do
-		(from, to) <- createPipe
-		(,) <$> fdToHandle to <*> fdToHandle from
-	rediroutput ss h
-		| willOutput ss = P.UseHandle h
-		| otherwise = ss
-#endif
-
-willOutput :: P.StdStream -> Bool
-willOutput P.Inherit = True
-willOutput _ = False
-
--- | Buffered output.
-data OutputBuffer = OutputBuffer [OutputBufferedActivity]
-	deriving (Eq)
-
-data StdHandle = StdOut | StdErr
-
-toHandle :: StdHandle -> Handle
-toHandle StdOut = stdout
-toHandle StdErr = stderr
-
-bufferFor :: StdHandle -> TMVar OutputBuffer
-bufferFor StdOut = outputBuffer globalOutputHandle
-bufferFor StdErr = errorBuffer globalOutputHandle
-
-data OutputBufferedActivity
-	= Output T.Text
-	| InTempFile
-		{ tempFile :: FilePath
-		, endsInNewLine :: Bool
-		}
-	deriving (Eq)
-
-data AtEnd = AtEnd
-	deriving Eq
-
-data BufSig = BufSig
-
-setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-setupOutputBuffer h toh ss fromh = do
-	hClose toh
-	buf <- newMVar (OutputBuffer [])
-	bufsig <- atomically newEmptyTMVar
-	bufend <- atomically newEmptyTMVar
-	void $ async $ outputDrainer ss fromh buf bufsig bufend
-	return (h, buf, bufsig, bufend)
-
--- Drain output from the handle, and buffer it.
-outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
-outputDrainer ss fromh buf bufsig bufend
-	| willOutput ss = go
-	| otherwise = atend
-  where
-	go = do
-		t <- T.hGetChunk fromh
-		if T.null t
-			then atend
-			else do
-				modifyMVar_ buf $ addOutputBuffer (Output t)
-				changed
-				go
-	atend = do
-		atomically $ putTMVar bufend AtEnd
-		hClose fromh
-	changed = atomically $ do
-		void $ tryTakeTMVar bufsig
-		putTMVar bufsig BufSig
-
-registerOutputThread :: IO ()
-registerOutputThread = do
-	let v = outputThreads globalOutputHandle
-	atomically $ putTMVar v . succ =<< takeTMVar v
-	
-unregisterOutputThread :: IO ()
-unregisterOutputThread = do
-	let v = outputThreads globalOutputHandle
-	atomically $ putTMVar v . pred =<< takeTMVar v
-
--- Wait to lock output, and once we can, display everything 
--- that's put into the buffers, until the end.
---
--- If end is reached before lock is taken, instead add the command's
--- buffers to the global outputBuffer and errorBuffer.
-bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO ()
-bufferWriter ts = do
-	activitysig <- atomically newEmptyTMVar
-	worker1 <- async $ lockOutput $
-		ifM (atomically $ tryPutTMVar activitysig ())
-			( void $ mapConcurrently displaybuf ts
-			, noop -- buffers already moved to global
-			)
-	worker2 <- async $ void $ globalbuf activitysig worker1
-	void $ async $ do
-		void $ waitCatch worker1
-		void $ waitCatch worker2
-		unregisterOutputThread
-  where
-	displaybuf v@(outh, buf, bufsig, bufend) = do
-		change <- atomically $
-			(Right <$> takeTMVar bufsig)
-				`orElse`
-			(Left <$> takeTMVar bufend)
-		l <- takeMVar buf
-		putMVar buf (OutputBuffer [])
-		emitOutputBuffer outh l
-		case change of
-			Right BufSig -> displaybuf v
-			Left AtEnd -> return ()
-	globalbuf activitysig worker1 = do
-		ok <- atomically $ do
-			-- signal we're going to handle it
-			-- (returns false if the displaybuf already did)
-			ok <- tryPutTMVar activitysig ()
-			-- wait for end of all buffers
-			when ok $
-				mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts
-			return ok
-		when ok $ do
-			-- add all of the command's buffered output to the
-			-- global output buffer, atomically
-			bs <- forM ts $ \(outh, buf, _bufsig, _bufend) ->
-				(outh,) <$> takeMVar buf
-			atomically $
-				forM_ bs $ \(outh, b) -> 
-					bufferOutputSTM' outh b
-			-- worker1 might be blocked waiting for the output
-			-- lock, and we've already done its job, so cancel it
-			cancel worker1
-
--- Adds a value to the OutputBuffer. When adding Output to a Handle,
--- it's cheaper to combine it with any already buffered Output to that
--- same Handle.
---
--- When the total buffered Output exceeds 1 mb in size, it's moved out of
--- memory, to a temp file. This should only happen rarely, but is done to
--- avoid some verbose process unexpectedly causing excessive memory use.
-addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
-addOutputBuffer (Output t) (OutputBuffer buf)
-	| T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other)
-	| otherwise = do
-		tmpdir <- getTemporaryDirectory
-		(tmp, h) <- openTempFile tmpdir "output.tmp"
-		let !endnl = endsNewLine t'
-		let i = InTempFile
-			{ tempFile = tmp
-			, endsInNewLine = endnl
-			}
-		T.hPutStr h t'
-		hClose h
-		return $ OutputBuffer (i : other)
-  where
-	!t' = T.concat (mapMaybe getOutput this) <> t
-	!(this, other) = partition isOutput buf
-	isOutput v = case v of
-		Output _ -> True
-		_ -> False
-	getOutput v = case v of
-		Output t'' -> Just t''
-		_ -> Nothing
-addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf)
-
--- | Adds a value to the output buffer for later display.
---
--- Note that buffering large quantities of data this way will keep it
--- resident in memory until it can be displayed. While `outputConcurrent`
--- uses temp files if the buffer gets too big, this STM function cannot do
--- so.
-bufferOutputSTM :: Outputable v => StdHandle -> v -> STM ()
-bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)])
-
-bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()
-bufferOutputSTM' h (OutputBuffer newbuf) = do
-	(OutputBuffer buf) <- takeTMVar bv
-	putTMVar bv (OutputBuffer (newbuf ++ buf))
-  where
-	bv = bufferFor h
-
--- | A STM action that waits for some buffered output to become
--- available, and returns it.
---
--- The function can select a subset of output when only some is desired;
--- the fst part is returned and the snd is left in the buffer.
---
--- This will prevent it from being displayed in the usual way, so you'll
--- need to use `emitOutputBuffer` to display it yourself.
-outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer)
-outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr
-  where
-	waitgetbuf h = do
-		let bv = bufferFor h
-		(selected, rest) <- selector <$> takeTMVar bv
-		when (selected == OutputBuffer [])
-			retry
-		putTMVar bv rest
-		return (h, selected)
-
-waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)
-waitAnyBuffer b = (b, OutputBuffer [])
-
--- | Use with `outputBufferWaiterSTM` to make it only return buffered
--- output that ends with a newline. Anything buffered without a newline
--- is left in the buffer.
-waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer)
-waitCompleteLines (OutputBuffer l) = 
-	let (selected, rest) = span completeline l
-	in (OutputBuffer selected, OutputBuffer rest)
-  where
-	completeline (v@(InTempFile {})) = endsInNewLine v
-	completeline (Output b) = endsNewLine b
-
-endsNewLine :: T.Text -> Bool
-endsNewLine t = not (T.null t) && T.last t == '\n'
-
--- | Emits the content of the OutputBuffer to the Handle
---
--- If you use this, you should use `lockOutput` to ensure you're the only
--- thread writing to the console.
-emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()
-emitOutputBuffer stdh (OutputBuffer l) = 
-	forM_ (reverse l) $ \ba -> case ba of
-		Output t -> emit t
-		InTempFile tmp _ -> do
-			emit =<< T.readFile tmp
-			void $ tryWhenExists $ removeFile tmp
-  where
-	outh = toHandle stdh
-	emit t = void $ tryIO $ do
-		T.hPutStr outh t
-		hFlush outh
diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs
deleted file mode 100644
index 0e00e4fd..00000000
--- a/src/System/Process/Concurrent.hs
+++ /dev/null
@@ -1,34 +0,0 @@
--- | 
--- Copyright: 2015 Joey Hess 
--- License: BSD-2-clause
--- 
--- The functions exported by this module are intended to be drop-in
--- replacements for those from System.Process, when converting a whole
--- program to use System.Console.Concurrent.
-
-module System.Process.Concurrent where
-
-import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
-import System.Process hiding (createProcess, waitForProcess)
-import System.IO
-import System.Exit
-
--- | Calls `createProcessConcurrent`
---
--- You should use the waitForProcess in this module on the resulting
--- ProcessHandle. Using System.Process.waitForProcess instead can have
--- mildly unexpected results.
-createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess p = do
-	(i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p
-	return (i, o, e, h)
-
--- | Calls `waitForProcessConcurrent`
---
--- You should only use this on a ProcessHandle obtained by calling
--- createProcess from this module. Using this with a ProcessHandle
--- obtained from System.Process.createProcess etc will have extremely
--- unexpected results; it can wait a very long time before returning.
-waitForProcess :: ProcessHandle -> IO ExitCode
-waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle
-- 
cgit v1.3-2-g0d8e


From ebdbac3243d7881e2bfac1ff293cf04c7cd69c91 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Mon, 28 Mar 2016 09:31:57 -0400
Subject: add

---
 doc/todo/chroot_should_type_check_inner_and_outer_OS.mdwn | 9 +++++++++
 1 file changed, 9 insertions(+)
 create mode 100644 doc/todo/chroot_should_type_check_inner_and_outer_OS.mdwn

(limited to 'doc')

diff --git a/doc/todo/chroot_should_type_check_inner_and_outer_OS.mdwn b/doc/todo/chroot_should_type_check_inner_and_outer_OS.mdwn
new file mode 100644
index 00000000..ff5d5434
--- /dev/null
+++ b/doc/todo/chroot_should_type_check_inner_and_outer_OS.mdwn
@@ -0,0 +1,9 @@
+Currently chroot properties containing any OS can be added to any host. Of
+course, some won't work. It would be nice to type check that the
+combination of inner and outer OS are compatable (ie, some linux on some
+linux).
+
+I have a partially done patch for that, but it failed at the last hurdle.
+See commit message 0b0ea182ab3301ade8b87b1be1cdecc3464cd1da 
+
+[[!tag users/joey]]
-- 
cgit v1.3-2-g0d8e


From cebf755a6710548bcff4474e6010eefb83db08ac Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Mon, 28 Mar 2016 11:06:23 -0400
Subject: close

---
 doc/todo/type_level_OS_requirements.mdwn | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'doc')

diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn
index f1c3e59f..fed1b279 100644
--- a/doc/todo/type_level_OS_requirements.mdwn
+++ b/doc/todo/type_level_OS_requirements.mdwn
@@ -52,3 +52,5 @@ work with that version, with some added ugliness.
 --[[Joey]]
 
 [[!tag user/joey]]
+
+> [[done]]!! --[[Joey]] 
-- 
cgit v1.3-2-g0d8e


From 351c06951753e38ddb238d9dca01f29ddef33eeb Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Wed, 30 Mar 2016 22:41:03 -0400
Subject: upgrade guide

---
 doc/forum/upgrading_to_propellor_3.0.mdwn | 72 +++++++++++++++++++++++++++++++
 1 file changed, 72 insertions(+)
 create mode 100644 doc/forum/upgrading_to_propellor_3.0.mdwn

(limited to 'doc')

diff --git a/doc/forum/upgrading_to_propellor_3.0.mdwn b/doc/forum/upgrading_to_propellor_3.0.mdwn
new file mode 100644
index 00000000..af54e938
--- /dev/null
+++ b/doc/forum/upgrading_to_propellor_3.0.mdwn
@@ -0,0 +1,72 @@
+Propellor 3.0 is a major new version with large changes to the API.
+
+Property types have been improved to indicate what systems they target.
+This prevents using eg, Property FreeBSD on a Debian system.
+
+This forum topic is to help users with the upgrade. Post comments
+if you're having trouble and [[Joey]] will get back to you. ;)
+
+First things first: In order to upgrade to propellor 3.0, you **must first
+upgrade to propellor 2.17.2**, and deploy that to all your hosts. If you
+skip this step, propellor --spin will fail when you upgrade to propellor
+3.0.0.  
+(Workaround: ssh to host, cd /usr/local/propellor && make clean,
+then you can re-run propellor --spin.)  
+[[details_of_why_this_two_step_upgrade_is_needed|todo/problem_with_spin_after_new_dependencies_added]]
+
+Now, the transition guide as far as your config.hs goes:
+
+* 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.
+* 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.
+
+Additional things you need to do if you've written your own properties:
+
+* 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"
+* 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
-- 
cgit v1.3-2-g0d8e


From 93b083f3a1204a7cf4452b5ebd589dd77d25dbac Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 1 Apr 2016 19:34:27 -0400
Subject: setup gpg key in initial setup process

---
 debian/changelog                                |  5 +-
 doc/README.mdwn                                 | 19 ++----
 doc/components.mdwn                             |  8 +--
 doc/todo/commandline_to_setup_minimal_repo.mdwn |  2 +
 src/Propellor/Gpg.hs                            | 17 +++--
 src/wrapper.hs                                  | 88 ++++++++++++++++++++++---
 6 files changed, 104 insertions(+), 35 deletions(-)

(limited to 'doc')

diff --git a/debian/changelog b/debian/changelog
index 14d3f1a9..21c53bf8 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -65,8 +65,9 @@ propellor (3.0.0) UNRELEASED; urgency=medium
   * Added dependency on concurrent-output; removed embedded copy.
   * Apt.PPA: New module, contributed by Evan Cofsky.
   * Improved propellor's first run experience; the wrapper program will
-    now walk the user through setting up ~/.propellor with a choice between
-    a clone of propellor's git repository, or a minimal config.
+    now 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.
 
  -- Joey Hess   Wed, 30 Mar 2016 15:45:08 -0400
 
diff --git a/doc/README.mdwn b/doc/README.mdwn
index b17f8575..fc3c3fd1 100644
--- a/doc/README.mdwn
+++ b/doc/README.mdwn
@@ -44,18 +44,13 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
      `apt-get install propellor`
 2. Run `propellor` for the first time. It 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!
diff --git a/doc/components.mdwn b/doc/components.mdwn
index 801bb6bf..5b47e106 100644
--- a/doc/components.mdwn
+++ b/doc/components.mdwn
@@ -28,12 +28,8 @@ then copy in `~/.propellor/src/Propellor/` and it will be used. See
 ## minimal .propellor repository
 
 All that really needs to be in `~/.propellor/` though, is a `config.hs`
-file, and a cabal file. To use propellor this way, you can first
-install propellor, and then copy the two files from the
-[mininalconfig branch](http://source.propellor.branchable.com/?p=source.git;a=tree;h=refs/heads/minimalconfig;hb=refs/heads/minimalconfig),
-or clone it:
-
-	git clone git://propellor.branchable.com/ .propellor --branch minimalconfig --single-branch
+file, and a cabal file. Running propellor when `~/.propellor/` doesn't exist
+will ask you if you want a minimal config, and create those files.
 
 In this configuration, when propellor is deploying itself to a new host,
 it will automatically install the version of the propellor library
diff --git a/doc/todo/commandline_to_setup_minimal_repo.mdwn b/doc/todo/commandline_to_setup_minimal_repo.mdwn
index 5e82ed0f..2b41d370 100644
--- a/doc/todo/commandline_to_setup_minimal_repo.mdwn
+++ b/doc/todo/commandline_to_setup_minimal_repo.mdwn
@@ -3,3 +3,5 @@ parameters, like --minimal to clone the minimal config repo instead of the
 full one, or --stack to set up ~/.propellor to use stack.  --[[Joey]]
 
 > Or, it could be an interactive setup process. --[[Joey]]
+
+>> Made it interactive. [[done]] --[[Joey]]
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index 55d89d29..4e6ceb79 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -32,14 +32,21 @@ getGpgBin = do
 -- 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]
diff --git a/src/wrapper.hs b/src/wrapper.hs
index 82251dc9..32e036da 100644
--- a/src/wrapper.hs
+++ b/src/wrapper.hs
@@ -3,8 +3,7 @@
 -- Distributions should install this program into PATH.
 -- (Cabal builds it as dist/build/propellor/propellor).
 --
--- This is not the propellor main program (that's config.hs)
---
+-- This is not the propellor main program (that's config.hs).
 -- This bootstraps ~/.propellor/config.hs, builds it if
 -- it's not already built, and runs it.
 
@@ -13,13 +12,16 @@ module Main where
 import Propellor.Message
 import Propellor.Bootstrap
 import Propellor.Git
+import Propellor.Gpg
 import Utility.UserInfo
 import Utility.Monad
 import Utility.Process
 import Utility.SafeCommand
 import Utility.Exception
+import Utility.Path
 
 import Data.Char
+import Data.List
 import Control.Monad
 import Control.Monad.IfElse
 import System.Directory
@@ -97,14 +99,14 @@ welcomeBanner = putStr $ unlines $ map prettify
 		| c == x = y
 		| otherwise = c
 
-prompt :: String -> [(Char, IO ())] -> IO ()
+prompt :: String -> [(String, IO ())] -> IO ()
 prompt p cs = do
-	putStr (p ++ " [" ++ map fst cs ++ "] ")
+	putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ")
 	hFlush stdout
 	r <- map toLower <$> getLine
-	if r == "\n"
+	if null r
 		then snd (head cs) -- default to first choice on return
-		else case filter (\(c, a) -> [toLower c] == r) cs of
+		else case filter (\(s, _) -> map toLower s == r) cs of
 			[(_, a)] -> a
 			_ -> do
 				putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)"
@@ -125,23 +127,89 @@ setup dotpropellor = do
 	putStrLn "   A: A clone of propellor's git repository    (most flexible)"
 	putStrLn "   B: The bare minimum files to use propellor  (most simple)"
 	prompt "Which would you prefer?"
-		[ ('A', fullClone dotpropellor),
-		 ('B', minimalConfig dotpropellor)
+		[ ("A", fullClone dotpropellor)
+		, ("B", minimalConfig dotpropellor)
 		]
 	putStrLn "Ok, ~/.propellor/config.hs is set up!"
-	
+	changeWorkingDirectory dotpropellor
+
 	section
 	putStrLn "Let's try building the propellor configuration, to make sure it will work..."
 	buildPropellor Nothing
-	putStrLn "Great! Propellor is set up and ready to use."
+	putStrLn "Great! Propellor is bootstrapped."
+	
+	section
+	putStrLn "Propellor uses gpg to encrypt private data about the systems it manages,"
+	putStrLn "and to sign git commits."
+	gpg <- getGpgBin
+	ifM (inPath gpg)
+		( setupGpgKey dotpropellor
+		, do
+			putStrLn "You don't seem to have gpg installed, so skipping setting it up."
+			explainManualSetupGpgKey
+		)
 
 	section
+	putStrLn "Everything is set up ..."
 	putStrLn "Your next step is to edit ~/.propellor/config.hs,"
 	putStrLn "and run propellor again to try it out."
 	putStrLn ""
 	putStrLn "For docs, see https://propellor.branchable.com/"
 	putStrLn "Enjoy propellor!"
 
+explainManualSetupGpgKey :: IO ()
+explainManualSetupGpgKey = do
+	putStrLn "Propellor can still be used without gpg, but it won't be able to"
+	putStrLn "manage private data. You can set this up later:"
+	putStrLn " 1. gpg --gen-key"
+	putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)"
+
+setupGpgKey :: FilePath -> IO ()
+setupGpgKey dotpropellor = do
+	ks <- listSecretKeys
+	putStrLn ""
+	case ks of
+		[] -> makeGpgKey dotpropellor
+		[(k, _)] -> propellorAddKey dotpropellor k
+		_ -> do
+			let nks = zip ks (map show ([1..] :: [Integer]))
+			putStrLn "I see you have several gpg keys:"
+			forM_ nks $ \((k, d), n) ->
+				putStrLn $ "   " ++ n ++ "   " ++ d ++ "  (keyid " ++ k ++ ")"
+			prompt "Which of your gpg keys should propellor use?"
+				(map (\((k, _), n) -> (n, propellorAddKey dotpropellor k)) nks)
+
+makeGpgKey :: FilePath -> IO ()
+makeGpgKey dotpropellor = do
+	putStrLn "You seem to not have any gpg secret keys."
+	prompt "Would you like to create one now?"
+		[("Y", rungpg), ("N", nope)]
+  where
+	nope = do
+		putStrLn "No problem."
+		explainManualSetupGpgKey
+	rungpg = do
+		putStrLn "Running gpg --gen-key ..."
+		gpg <- getGpgBin
+		void $ boolSystem gpg [Param "--gen-key"]
+		ks <- listSecretKeys
+		case ks of
+			[] -> do
+				putStrLn "Hmm, gpg seemed to not set up a secret key."
+				prompt "Want to try running gpg again?"
+					[("Y", rungpg), ("N", nope)]
+			((k, _):_) -> propellorAddKey dotpropellor k
+
+propellorAddKey :: FilePath -> String -> IO ()
+propellorAddKey dotpropellor keyid = do
+	putStrLn ""
+	putStrLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid
+	unlessM (boolSystem propellorbin [Param "--add-key", Param keyid]) $ do
+		putStrLn "Oops, that didn't work! You can retry the same command later."
+		putStrLn "Continuing onward ..."
+  where
+	propellorbin = dotpropellor  "propellor"
+
 minimalConfig :: FilePath -> IO ()
 minimalConfig dotpropellor = do
 	createDirectoryIfMissing True dotpropellor
-- 
cgit v1.3-2-g0d8e


From 1dc914a71c94e0395641565e5891a2dc33ba1b35 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 1 Apr 2016 21:20:13 -0400
Subject: separate propellor --init

---
 debian/changelog               |   4 +-
 doc/README.mdwn                |   2 +-
 propellor.cabal                |   1 +
 src/Propellor/CmdLine.hs       |   4 +
 src/Propellor/DotDir.hs        | 348 ++++++++++++++++++++++++++++++++++++++++
 src/Propellor/Types/CmdLine.hs |   1 +
 src/wrapper.hs                 | 353 ++---------------------------------------
 7 files changed, 370 insertions(+), 343 deletions(-)
 create mode 100644 src/Propellor/DotDir.hs

(limited to 'doc')

diff --git a/debian/changelog b/debian/changelog
index 21c53bf8..ae593902 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -64,8 +64,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium
     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; the wrapper program will
-    now walk the user through setting up ~/.propellor, with a choice between
+  * 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.
 
diff --git a/doc/README.mdwn b/doc/README.mdwn
index fc3c3fd1..31d222c1 100644
--- a/doc/README.mdwn
+++ b/doc/README.mdwn
@@ -42,7 +42,7 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
      `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. Edit `~/.propellor/config.hs`, and add a host you want to manage.
    You can start by not adding any properties, or only a few.
diff --git a/propellor.cabal b/propellor.cabal
index 9f74d264..d97d4096 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -151,6 +151,7 @@ Library
     Propellor.Info
     Propellor.Message
     Propellor.Debug
+    Propellor.DotDir
     Propellor.PrivData
     Propellor.Engine
     Propellor.EnsureProperty
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index d93a8e3a..19e49f5a 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -16,6 +16,7 @@ import Propellor.Git.VerifiedBranch
 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 @@ import qualified Propellor.Shim as Shim
 usage :: Handle -> IO ()
 usage h = hPutStrLn h $ unlines
 	[ "Usage:"
+	, "  propellor --init"
 	, "  propellor"
 	, "  propellor hostname"
 	, "  propellor --spin targethost [--via relayhost]"
@@ -69,6 +71,7 @@ processCmdLine = go =<< getArgs
 	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 @@ defaultMain hostlist = withConcurrentOutput $ do
 		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)
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
new file mode 100644
index 00000000..92c20654
--- /dev/null
+++ b/src/Propellor/DotDir.hs
@@ -0,0 +1,348 @@
+module Propellor.DotDir where
+
+import Propellor.Message
+import Propellor.Bootstrap
+import Propellor.Git
+import Propellor.Gpg
+import Utility.UserInfo
+import Utility.Monad
+import Utility.Process
+import Utility.SafeCommand
+import Utility.Exception
+import Utility.Path
+
+import Data.Char
+import Data.List
+import Control.Monad
+import Control.Monad.IfElse
+import System.Directory
+import System.FilePath
+import System.Posix.Directory
+import System.IO
+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")
+
+interactiveInit :: IO ()
+interactiveInit = ifM (doesDirectoryExist =<< dotPropellor)
+	( error "~/.propellor/ already exists, not doing anything"
+	, do
+		welcomeBanner
+		setup
+	)
+
+welcomeBanner :: IO ()
+welcomeBanner = putStr $ 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
+	putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ")
+	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
+				putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)"
+				prompt p cs
+
+section :: IO ()
+section = do
+	putStrLn ""
+	putStrLn "---------------------------------------------------------------------------------"
+	putStrLn ""
+
+setup :: IO ()
+setup = do
+	dotpropellor <- dotPropellor
+	putStrLn "Propellor's configuration file is ~/.propellor/config.hs"
+	putStrLn ""
+	putStrLn "Lets get you started with a simple config that you can adapt"
+	putStrLn "to your needs. You can start with:"
+	putStrLn "   A: A clone of propellor's git repository    (most flexible)"
+	putStrLn "   B: The bare minimum files to use propellor  (most simple)"
+	prompt "Which would you prefer?"
+		[ ("A", fullClone)
+		, ("B", minimalConfig)
+		]
+	putStrLn "Ok, ~/.propellor/config.hs is set up!"
+	changeWorkingDirectory dotpropellor
+
+	section
+	putStrLn "Let's try building the propellor configuration, to make sure it will work..."
+	buildPropellor Nothing
+	putStrLn "Great! Propellor is bootstrapped."
+	
+	section
+	putStrLn "Propellor uses gpg to encrypt private data about the systems it manages,"
+	putStrLn "and to sign git commits."
+	gpg <- getGpgBin
+	ifM (inPath gpg)
+		( setupGpgKey
+		, do
+			putStrLn "You don't seem to have gpg installed, so skipping setting it up."
+			explainManualSetupGpgKey
+		)
+
+	section
+	putStrLn "Everything is set up ..."
+	putStrLn "Your next step is to edit ~/.propellor/config.hs,"
+	putStrLn "and run propellor again to try it out."
+	putStrLn ""
+	putStrLn "For docs, see https://propellor.branchable.com/"
+	putStrLn "Enjoy propellor!"
+
+explainManualSetupGpgKey :: IO ()
+explainManualSetupGpgKey = do
+	putStrLn "Propellor can still be used without gpg, but it won't be able to"
+	putStrLn "manage private data. You can set this up later:"
+	putStrLn " 1. gpg --gen-key"
+	putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)"
+
+setupGpgKey :: IO ()
+setupGpgKey = do
+	ks <- listSecretKeys
+	putStrLn ""
+	case ks of
+		[] -> makeGpgKey
+		[(k, _)] -> propellorAddKey k
+		_ -> do
+			let nks = zip ks (map show ([1..] :: [Integer]))
+			putStrLn "I see you have several gpg keys:"
+			forM_ nks $ \((k, d), n) ->
+				putStrLn $ "   " ++ n ++ "   " ++ d ++ "  (keyid " ++ k ++ ")"
+			prompt "Which of your gpg keys should propellor use?"
+				(map (\((k, _), n) -> (n, propellorAddKey k)) nks)
+
+makeGpgKey :: IO ()
+makeGpgKey = do
+	putStrLn "You seem to not have any gpg secret keys."
+	prompt "Would you like to create one now?"
+		[("Y", rungpg), ("N", nope)]
+  where
+	nope = do
+		putStrLn "No problem."
+		explainManualSetupGpgKey
+	rungpg = do
+		putStrLn "Running gpg --gen-key ..."
+		gpg <- getGpgBin
+		void $ boolSystem gpg [Param "--gen-key"]
+		ks <- listSecretKeys
+		case ks of
+			[] -> do
+				putStrLn "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
+	putStrLn ""
+	putStrLn $ "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
+		putStrLn "Oops, that didn't work! You can retry the same command later."
+		putStrLn "Continuing onward ..."
+
+minimalConfig :: IO ()
+minimalConfig = do
+	d <- dotPropellor
+	createDirectoryIfMissing True d
+	let cabalfile = d  "config.cabal"
+	let configfile = d  "config.hs"
+	writeFile cabalfile (unlines cabalcontent)
+	writeFile configfile (unlines configcontent)
+	changeWorkingDirectory d
+	void $ boolSystem "git" [Param "init"]
+	void $ boolSystem "git" [Param "add" , File cabalfile, File configfile]
+  where
+	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."
+		, ""
+		, "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 * * * *\")"
+		, ""
+		]
+
+fullClone :: IO ()
+fullClone = do
+	d <- dotPropellor
+	ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)
+		( do			
+			void $ boolSystem "git" [Param "clone", File distrepo, File d]
+			fetchUpstreamBranch distrepo
+			changeWorkingDirectory d
+			void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]
+		, do
+			void $ boolSystem "git" [Param "clone", Param netrepo, File d]
+			changeWorkingDirectory d
+			-- Rename origin to upstream and avoid
+			-- git push to that read-only repo.
+			void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"]
+			void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"]
+		)
+
+fetchUpstreamBranch :: FilePath -> IO ()
+fetchUpstreamBranch repo = do
+	changeWorkingDirectory =<< dotPropellor
+	void $ 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")
+
+-- Passed the user's dotpropellor repository, makes upstream/master
+-- 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"]
+	
+		fetchUpstreamBranch tmprepo
+		cleantmprepo
+		warnoutofdate True
+
+	getoldrev = takeWhile (/= '\n')
+		<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]
+	
+	git = run "git"
+	run cmd ps = unlessM (boolSystem cmd (map Param ps)) $
+		error $ "Failed to run " ++ cmd ++ " " ++ show ps
+
+warnoutofdate :: Bool -> IO ()
+warnoutofdate havebranch = do
+	warningMessage ("** Your ~/.propellor/ is out of date..")
+	let also s = hPutStrLn stderr ("   " ++ s)
+	also ("A newer upstream version is available in " ++ distrepo)
+	if havebranch
+		then also ("To merge it, run: git merge " ++ upstreambranch)
+		else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.")
+	also ""
diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs
index 558c6e8b..0773d9d9 100644
--- a/src/Propellor/Types/CmdLine.hs
+++ b/src/Propellor/Types/CmdLine.hs
@@ -28,4 +28,5 @@ data CmdLine
 	| ChrootChain HostName FilePath Bool Bool
 	| GitPush Fd Fd
 	| Check
+	| Init
 	deriving (Read, Show, Eq)
diff --git a/src/wrapper.hs b/src/wrapper.hs
index 32e036da..1a90fcb0 100644
--- a/src/wrapper.hs
+++ b/src/wrapper.hs
@@ -9,360 +9,33 @@
 
 module Main where
 
+import Propellor.DotDir
 import Propellor.Message
 import Propellor.Bootstrap
-import Propellor.Git
-import Propellor.Gpg
-import Utility.UserInfo
 import Utility.Monad
 import Utility.Process
-import Utility.SafeCommand
-import Utility.Exception
-import Utility.Path
 
-import Data.Char
-import Data.List
-import Control.Monad
-import Control.Monad.IfElse
 import System.Directory
-import System.FilePath
 import System.Environment (getArgs)
 import System.Exit
 import System.Posix.Directory
-import System.IO
-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"
 
 main :: IO ()
-main = withConcurrentOutput $ do
-	args <- getArgs
-	home <- myHomeDir
-	let dotpropellor = home  ".propellor"
-	ifM (doesDirectoryExist dotpropellor)
+main = withConcurrentOutput $ go =<< getArgs
+  where
+	go ["--init"] = interactiveInit
+	go args = ifM (doesDirectoryExist =<< dotPropellor)
 		( do
-			checkRepoUpToDate dotpropellor
-			buildRunConfig dotpropellor args
-		, do
-			welcomeBanner
-			setup dotpropellor
+			checkRepoUpToDate
+			buildRunConfig args
+		, error "Seems that ~/.propellor/ does not exist. To set it up, run: propellor --init"
 		)
 
-buildRunConfig :: FilePath -> [String] -> IO ()
-buildRunConfig dotpropellor args = do
-	changeWorkingDirectory dotpropellor
-	buildPropellor Nothing
-	putStrLn ""
-	putStrLn ""
-	chain
-  where
-	propellorbin = dotpropellor  "propellor"
-	chain = do
-		(_, _, _, pid) <- createProcess (proc propellorbin args) 
-		exitWith =<< waitForProcess pid
-
-welcomeBanner :: IO ()
-welcomeBanner = putStr $ 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
-	putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ")
-	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
-				putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)"
-				prompt p cs
-
-section :: IO ()
-section = do
-	putStrLn ""
-	putStrLn "---------------------------------------------------------------------------------"
-	putStrLn ""
-
-setup :: FilePath -> IO ()
-setup dotpropellor = do
-	putStrLn "Propellor's configuration file is ~/.propellor/config.hs"
-	putStrLn ""
-	putStrLn "Lets get you started with a simple config that you can adapt"
-	putStrLn "to your needs. You can start with:"
-	putStrLn "   A: A clone of propellor's git repository    (most flexible)"
-	putStrLn "   B: The bare minimum files to use propellor  (most simple)"
-	prompt "Which would you prefer?"
-		[ ("A", fullClone dotpropellor)
-		, ("B", minimalConfig dotpropellor)
-		]
-	putStrLn "Ok, ~/.propellor/config.hs is set up!"
-	changeWorkingDirectory dotpropellor
-
-	section
-	putStrLn "Let's try building the propellor configuration, to make sure it will work..."
+buildRunConfig :: [String] -> IO ()
+buildRunConfig args = do
+	changeWorkingDirectory =<< dotPropellor
 	buildPropellor Nothing
-	putStrLn "Great! Propellor is bootstrapped."
-	
-	section
-	putStrLn "Propellor uses gpg to encrypt private data about the systems it manages,"
-	putStrLn "and to sign git commits."
-	gpg <- getGpgBin
-	ifM (inPath gpg)
-		( setupGpgKey dotpropellor
-		, do
-			putStrLn "You don't seem to have gpg installed, so skipping setting it up."
-			explainManualSetupGpgKey
-		)
-
-	section
-	putStrLn "Everything is set up ..."
-	putStrLn "Your next step is to edit ~/.propellor/config.hs,"
-	putStrLn "and run propellor again to try it out."
 	putStrLn ""
-	putStrLn "For docs, see https://propellor.branchable.com/"
-	putStrLn "Enjoy propellor!"
-
-explainManualSetupGpgKey :: IO ()
-explainManualSetupGpgKey = do
-	putStrLn "Propellor can still be used without gpg, but it won't be able to"
-	putStrLn "manage private data. You can set this up later:"
-	putStrLn " 1. gpg --gen-key"
-	putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)"
-
-setupGpgKey :: FilePath -> IO ()
-setupGpgKey dotpropellor = do
-	ks <- listSecretKeys
-	putStrLn ""
-	case ks of
-		[] -> makeGpgKey dotpropellor
-		[(k, _)] -> propellorAddKey dotpropellor k
-		_ -> do
-			let nks = zip ks (map show ([1..] :: [Integer]))
-			putStrLn "I see you have several gpg keys:"
-			forM_ nks $ \((k, d), n) ->
-				putStrLn $ "   " ++ n ++ "   " ++ d ++ "  (keyid " ++ k ++ ")"
-			prompt "Which of your gpg keys should propellor use?"
-				(map (\((k, _), n) -> (n, propellorAddKey dotpropellor k)) nks)
-
-makeGpgKey :: FilePath -> IO ()
-makeGpgKey dotpropellor = do
-	putStrLn "You seem to not have any gpg secret keys."
-	prompt "Would you like to create one now?"
-		[("Y", rungpg), ("N", nope)]
-  where
-	nope = do
-		putStrLn "No problem."
-		explainManualSetupGpgKey
-	rungpg = do
-		putStrLn "Running gpg --gen-key ..."
-		gpg <- getGpgBin
-		void $ boolSystem gpg [Param "--gen-key"]
-		ks <- listSecretKeys
-		case ks of
-			[] -> do
-				putStrLn "Hmm, gpg seemed to not set up a secret key."
-				prompt "Want to try running gpg again?"
-					[("Y", rungpg), ("N", nope)]
-			((k, _):_) -> propellorAddKey dotpropellor k
-
-propellorAddKey :: FilePath -> String -> IO ()
-propellorAddKey dotpropellor keyid = do
 	putStrLn ""
-	putStrLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid
-	unlessM (boolSystem propellorbin [Param "--add-key", Param keyid]) $ do
-		putStrLn "Oops, that didn't work! You can retry the same command later."
-		putStrLn "Continuing onward ..."
-  where
-	propellorbin = dotpropellor  "propellor"
-
-minimalConfig :: FilePath -> IO ()
-minimalConfig dotpropellor = do
-	createDirectoryIfMissing True dotpropellor
-	writeFile cabalfile (unlines cabalcontent)
-	writeFile configfile (unlines configcontent)
-	changeWorkingDirectory dotpropellor
-	void $ boolSystem "git" [Param "init"]
-	void $ boolSystem "git" [Param "add" , File cabalfile, File configfile]
-  where
-	cabalfile = dotpropellor  "config.cabal"
-	configfile = dotpropellor  "config.hs"
-	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."
-		, ""
-		, "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 * * * *\")"
-		, ""
-		]
-
-fullClone :: FilePath -> IO ()
-fullClone dotpropellor = ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)
-	( do			
-		void $ boolSystem "git" [Param "clone", File distrepo, File dotpropellor]
-		fetchUpstreamBranch dotpropellor distrepo
-		changeWorkingDirectory dotpropellor
-		void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]
-	, do
-		void $ boolSystem "git" [Param "clone", Param netrepo, File dotpropellor]
-		changeWorkingDirectory dotpropellor
-		-- Rename origin to upstream and avoid
-		-- git push to that read-only repo.
-		void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"]
-		void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"]
-	)
-
-checkRepoUpToDate :: FilePath -> IO ()
-checkRepoUpToDate dotpropellor = 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 dotpropellor
-		else do
-			theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef
-			when (theirhead /= headrev) $ do
-				merged <- not . null <$>
-					readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"]
-				unless merged $
-					warnoutofdate dotpropellor True
-  where
-	gitbundleavail = doesFileExist disthead
-	dotpropellorpopulated = doesFileExist (dotpropellor  "propellor.cabal")
-
--- Passed the user's dotpropellor repository, makes upstream/master
--- 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 -> FilePath -> IO ()
-setupUpstreamMaster newref dotpropellor = do
-	changeWorkingDirectory dotpropellor
-	go =<< catchMaybeIO getoldrev
-  where
-	go Nothing = warnoutofdate dotpropellor 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"]
-	
-		fetchUpstreamBranch dotpropellor tmprepo
-		cleantmprepo
-		warnoutofdate dotpropellor 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 :: FilePath -> Bool -> IO ()
-warnoutofdate dotpropellor havebranch = do
-	warningMessage ("** Your " ++ dotpropellor ++ " 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 ""
-
-fetchUpstreamBranch :: FilePath -> FilePath -> IO ()
-fetchUpstreamBranch dotpropellor repo = do
-	changeWorkingDirectory dotpropellor
-	void $ boolSystem "git"
-		[ Param "fetch"
-		, File repo
-		, Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch)
-		, Param "--quiet"
-		]
+	(_, _, _, pid) <- createProcess (proc "./propellor" args) 
+	exitWith =<< waitForProcess pid
-- 
cgit v1.3-2-g0d8e


From e3920861ee444945e54fd42ce0f599d585155652 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Sat, 2 Apr 2016 01:29:23 -0400
Subject: Stack support.

* 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.
---
 Makefile                                           |  1 +
 debian/changelog                                   |  4 ++
 ...use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn |  6 +++
 propellor.cabal                                    |  6 +++
 src/Propellor/Bootstrap.hs                         | 54 ++++++++++++++++++----
 src/Propellor/DotDir.hs                            | 47 +++++++++++++++----
 stack.yaml                                         |  6 +++
 7 files changed, 107 insertions(+), 17 deletions(-)
 create mode 100644 stack.yaml

(limited to 'doc')

diff --git a/Makefile b/Makefile
index a9ad2b84..5322d6c5 100644
--- a/Makefile
+++ b/Makefile
@@ -16,6 +16,7 @@ install:
 	mkdir -p dist/gittmp
 	$(CABAL) sdist
 	cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1)
+	cp stack.yaml dist/gittmp # also include in bundle
 	# cabal sdist does not preserve symlinks, so copy over file
 	cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done
 	# reset mtime on files in git bundle so bundle is reproducible
diff --git a/debian/changelog b/debian/changelog
index ae593902..aab077b0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -68,6 +68,10 @@ propellor (3.0.0) UNRELEASED; urgency=medium
     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   Wed, 30 Mar 2016 15:45:08 -0400
 
diff --git a/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn b/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn
index 2973e662..55c3ef7e 100644
--- a/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn
+++ b/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn
@@ -7,3 +7,9 @@ and run with
     stack exec -- propellor ...
 
 see [[https://github.com/yesodweb/yesod/issues/1018]] and [[https://github.com/yesodweb/yesod/commit/a7cccf2a7c5df8b26da9ea4fdcb6bac5ab3a3b75]]
+
+> I don't think `stack exec propellor` makes sense to use.
+> Instead, `stack install propellor` and then put that in PATH.
+> I've now made `propellor --init` know when it was built using stack,
+> and it will set up propellor to continue to build itself using stack.
+> [[done]] --[[Joey]]
diff --git a/propellor.cabal b/propellor.cabal
index d97d4096..3431d410 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -34,6 +34,10 @@ Description:
  .
  It is configured using haskell.
 
+Flag UseStack
+  Description: Have propellor rebuild itself using Stack (default is Cabal)
+  Default: False
+
 Executable propellor
   Main-Is: wrapper.hs
   GHC-Options: -threaded -Wall -fno-warn-tabs -O0
@@ -46,6 +50,8 @@ Executable propellor
     unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,
     time, mtl, transformers, exceptions (>= 0.6), stm, text,
     concurrent-output
+  if flag(UseStack)
+    CPP-Options: -DUSE_STACK
 
 Executable propellor-config
   Main-Is: config.hs
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 969e1a42..300be156 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -7,6 +7,7 @@ module Propellor.Bootstrap (
 
 import Propellor.Base
 import Propellor.Types.Info
+import Propellor.Git.Config
 
 import System.Posix.Files
 import Data.List
@@ -139,16 +140,22 @@ buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $
 		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) $
@@ -163,14 +170,11 @@ build msys = catchBoolIO $ do
 	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
@@ -181,6 +185,35 @@ build msys = catchBoolIO $ do
 		)
 	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
@@ -193,3 +226,6 @@ make dest srcs builder = do
 
 cabal :: [String] -> IO Bool
 cabal = boolSystem "cabal" . map Param
+
+stack :: [String] -> IO Bool
+stack = boolSystem "stack" . map Param
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index f0dace2f..90147abe 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Propellor.DotDir where
 
 import Propellor.Message
@@ -11,9 +13,12 @@ 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
@@ -48,6 +53,15 @@ dotPropellor = do
 	home <- myHomeDir
 	return (home  ".propellor")
 
+data InitCfg = UseCabal | UseStack
+
+initCfg :: InitCfg
+#ifdef USE_STACK
+initCfg = UseStack
+#else
+initCfg = UseCabal
+#endif
+
 interactiveInit :: IO ()
 interactiveInit = ifM (doesDirectoryExist =<< dotPropellor)
 	( error "~/.propellor/ already exists, not doing anything"
@@ -95,7 +109,7 @@ section = do
 	putStrLn ""
 
 setup :: IO ()
-setup = do
+setup initcfg = do
 	putStrLn "Propellor's configuration file is ~/.propellor/config.hs"
 	putStrLn ""
 	putStrLn "Lets get you started with a simple config that you can adapt"
@@ -103,14 +117,21 @@ setup = do
 	putStrLn "   A: A clone of propellor's git repository    (most flexible)"
 	putStrLn "   B: The bare minimum files to use propellor  (most simple)"
 	prompt "Which would you prefer?"
-		[ ("A", actionMessage "Cloning propellor's git repository" fullClone >> return ())
-		, ("B", actionMessage "Creating minimal config" minimalConfig >> return ())
+		[ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone)
+		, ("B", void $ actionMessage "Creating minimal config" minimalConfig)
 		]
 	changeWorkingDirectory =<< dotPropellor
 
 	section
 	putStrLn "Let's try building the propellor configuration, to make sure it will work..."
 	putStrLn ""
+	void $ boolSystem "git"
+		[ Param "config"
+		, Param "propellor.buildsystem"
+		, Param $ case initCfg of
+			UseCabal -> "cabal"
+			UseStack -> "stack"
+		]
 	buildPropellor Nothing
 	putStrLn ""
 	putStrLn "Great! Propellor is bootstrapped."
@@ -197,15 +218,16 @@ minimalConfig :: IO Result
 minimalConfig = do
 	d <- dotPropellor
 	createDirectoryIfMissing True d
-	let cabalfile = d  "config.cabal"
-	let configfile = d  "config.hs"
-	writeFile cabalfile (unlines cabalcontent)
-	writeFile configfile (unlines configcontent)
 	changeWorkingDirectory d
 	void $ boolSystem "git" [Param "init"]
-	void $ boolSystem "git" [Param "add" , File cabalfile, File configfile]
+	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."
 		, ""
@@ -252,6 +274,15 @@ minimalConfig = do
 		, "        & 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
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 00000000..6b5e859c
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,6 @@
+resolver: lts-5.10
+packages:
+- '.'
+flags:
+  propellor:
+    usestack: true
-- 
cgit v1.3-2-g0d8e