From 7ee3157ab1922fd2f7158fd40927dca8a83ad4b0 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 24 Mar 2016 15:17:16 -0400
Subject: docs and enable PolyKinds globally

---
 debian/changelog | 32 ++++++++++++++++++++++++++++++--
 1 file changed, 30 insertions(+), 2 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index 2c2b2ea7..c9286fcf 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,31 @@
+propellor (3.0.0) UNRELEASED; urgency=medium
+
+  * Property types have been improved to indicate what systems they target.
+    Transition guide:
+    - Change "Property NoInfo" to "Property UnixLike"
+    - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"
+    - Change "RevertableProperty NoInfo" to
+      "RevertableProperty UnixLike UnixLike"
+    - Change "RevertableProperty HasInfo" to
+      "RevertableProperty (HasInfo + UnixLike) UnixLike"
+    - GHC needs {-# LANGUAGE PolyKinds #-} to use these new type signatures.
+      This is enabled by default for all modules in propellor.cabal. But
+      if you are using propellor as a library, you may need to enable it
+      manually.
+    - If you know a property only works on a particular OS, like Debian
+      or FreeBSD, use that instead of "UnixLike". For example:
+      "Property (HasInfo + Debian)"
+    - It's also possible make a property support a set of OS's, for example:
+      "Property (HasInfo + Debian + FreeBSD)"
+    - 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.
+    - `ensureProperty` now needs information about the metatypes of the
+      property it's used in to be passed to it. See the documentation
+      of `ensureProperty` for an example.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 24 Mar 2016 15:02:33 -0400
+
 propellor (2.17.0) unstable; urgency=medium
 
   * Added initial support for FreeBSD.
@@ -470,12 +498,12 @@ propellor (2.0.0) unstable; urgency=medium
     This was done to make sure that ensureProperty is only used on
     properties that do not have Info.
     Transition guide:
-    - Change all "Property" to "Property NoInfo" or "Property WithInfo"
+    - Change all "Property" to "Property NoInfo" or "Property HasInfo"
       (The compiler can tell you if you got it wrong!)
     - To construct a RevertableProperty, it is useful to use the new
       (<!>) operator
     - Constructing a list of properties can be problimatic, since
-      Property NoInto and Property WithInfo are different types and cannot
+      Property NoInto and Property HasInfo are different types and cannot
       appear in the same list. To deal with this, "props" has been added,
       and can built up a list of properties of different types,
       using the same (&) and (!) operators that are used to build
-- 
cgit v1.3-2-g0d8e


From f5e7596cb9183158644fdd2df9996871dc0a8efa Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 24 Mar 2016 15:42:47 -0400
Subject: converted Propellor.Info

---
 debian/changelog       |  2 +-
 src/Propellor/Info.hs  | 19 +++++++++++--------
 src/Propellor/Types.hs |  5 +++--
 3 files changed, 15 insertions(+), 11 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index c9286fcf..f1138eb2 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -8,7 +8,7 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       "RevertableProperty UnixLike UnixLike"
     - Change "RevertableProperty HasInfo" to
       "RevertableProperty (HasInfo + UnixLike) UnixLike"
-    - GHC needs {-# LANGUAGE PolyKinds #-} to use these new type signatures.
+    - GHC needs {-# LANGUAGE TypeOperators #-} to use these new type signatures.
       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.
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 7eb7d4a8..4827ba8a 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -13,11 +13,14 @@ import Data.Monoid
 import Control.Applicative
 import Prelude
 
-pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo
+pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)
 pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v)
 
-pureInfoProperty' :: Desc -> Info -> Property HasInfo
-pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
+pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
+pureInfoProperty' desc i = addInfoProperty p i
+  where
+	p :: Property UnixLike
+	p = mkProperty ("has " ++ desc) (return NoChange)
 
 -- | Gets a value from the host's Info.
 askInfo :: (IsInfo v) => Propellor v
@@ -27,7 +30,7 @@ askInfo = asks (getInfo . hostInfo)
 --
 -- This only provides info for other Properties, so they can act
 -- conditionally on the os.
-os :: System -> Property HasInfo
+os :: System -> Property (HasInfo + UnixLike)
 os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)
 
 --  Gets the operating system of a host, if it has been specified.
@@ -43,11 +46,11 @@ getOS = fromInfoVal <$> askInfo
 -- When propellor --spin is used to deploy a host, it checks
 -- if the host's IP Property matches the DNS. If the DNS is missing or
 -- out of date, the host will instead be contacted directly by IP address.
-ipv4 :: String -> Property HasInfo
+ipv4 :: String -> Property (HasInfo + UnixLike)
 ipv4 = addDNS . Address . IPv4
 
 -- | Indicate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property HasInfo
+ipv6 :: String -> Property (HasInfo + UnixLike)
 ipv6 = addDNS . Address . IPv6
 
 -- | Indicates another name for the host in the DNS.
@@ -56,14 +59,14 @@ ipv6 = addDNS . Address . IPv6
 -- to use their address, rather than using a CNAME. This avoids various
 -- problems with CNAMEs, and also means that when multiple hosts have the
 -- same alias, a DNS round-robin is automatically set up.
-alias :: Domain -> Property HasInfo
+alias :: Domain -> Property (HasInfo + UnixLike)
 alias d = pureInfoProperty' ("alias " ++ d) $ mempty
 	`addInfo` toAliasesInfo [d]
 	-- A CNAME is added here, but the DNS setup code converts it to an
 	-- IP address when that makes sense.
 	`addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)
 
-addDNS :: Record -> Property HasInfo
+addDNS :: Record -> Property (HasInfo + UnixLike)
 addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))
   where
 	rdesc (CNAME d) = unwords ["alias", ddesc d]
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 25269969..49ba9220 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -149,11 +149,12 @@ mkProperty d a = Property sing d a mempty mempty
 --
 -- The new Property will include HasInfo in its metatypes.
 addInfoProperty
-	:: (metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
+	:: (Sing metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
 	=> Property metatypes
 	-> Info
 	-> Property (Sing metatypes')
-addInfoProperty (Property metatypes d a i c) newi = Property sing d a (i <> newi) c
+addInfoProperty (Property metatypes d a oldi c) newi =
+	Property sing d a (oldi <> newi) c
 
 {-
 
-- 
cgit v1.3-2-g0d8e


From 63ed6dcd7b2e916f17514abe7860df9a135e1be9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 24 Mar 2016 17:31:47 -0400
Subject: docs

---
 debian/changelog | 11 +++++++----
 propellor.cabal  |  2 +-
 2 files changed, 8 insertions(+), 5 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index f1138eb2..323394f9 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,7 +1,8 @@
 propellor (3.0.0) UNRELEASED; urgency=medium
 
   * Property types have been improved to indicate what systems they target.
-    Transition guide:
+    This allows, eg, Property Debian to not be used on a FreeBSD system.
+    Transition guide for this sweeping API change:
     - Change "Property NoInfo" to "Property UnixLike"
     - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"
     - Change "RevertableProperty NoInfo" to
@@ -17,12 +18,14 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       "Property (HasInfo + Debian)"
     - It's also possible make a property support a set of OS's, for example:
       "Property (HasInfo + Debian + FreeBSD)"
+    - `ensureProperty` now needs information about the metatypes of the
+      property it's used in to be passed to it. See the documentation
+      of `ensureProperty` for an example, but basically, change
+      this:     foo = property desc $ ... ensureProperty bar
+      to this:  foo = property' desc $ \o -> ... ensureProperty o bar
     - 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.
-    - `ensureProperty` now needs information about the metatypes of the
-      property it's used in to be passed to it. See the documentation
-      of `ensureProperty` for an example.
 
  -- Joey Hess <id@joeyh.name>  Thu, 24 Mar 2016 15:02:33 -0400
 
diff --git a/propellor.cabal b/propellor.cabal
index a13ebcb5..c8c68e48 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
 Name: propellor
-Version: 2.17.0
+Version: 3.0.0
 Cabal-Version: >= 1.8
 License: BSD3
 Maintainer: Joey Hess <id@joeyh.name>
-- 
cgit v1.3-2-g0d8e


From e3a44ab5825466f9db9c4749497445bd0af1068e Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 24 Mar 2016 20:20:34 -0400
Subject: add tightenTargets, ported Network properties (DebinLike only)

---
 debian/changelog                  |  6 +++++
 src/Propellor/Property.hs         | 47 +++++++++++++++++++++++++++++++++++++++
 src/Propellor/Property/Network.hs | 39 ++++++++++++++++++--------------
 3 files changed, 75 insertions(+), 17 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index 323394f9..ead6585e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -23,6 +23,12 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       of `ensureProperty` for an example, but basically, change
       this:     foo = property desc $ ... ensureProperty bar
       to this:  foo = property' desc $ \o -> ... ensureProperty o 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 targets to only the OS that your more specific
+      property works on. For example:
+        upgraded :: Property Debian
+        upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"])
     - 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/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 27d17135..cab233d0 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
 
 module Propellor.Property (
 	-- * Property combinators
@@ -20,6 +23,7 @@ module Propellor.Property (
 	, property
 	, property'
 	, ensureProperty
+	, tightenTargets
 	--, withOS
 	, unsupportedOS
 	, makeChange
@@ -240,6 +244,49 @@ isNewerThan x y = do
   where
 	mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
 
+-- | Tightens the MetaType list of a Property, to contain fewer targets.
+--
+-- Anything else in the MetaType list is passed through unchanged.
+--
+-- For example, to make a property that uses apt-get, which is only
+-- available on DebianLike systems:
+--
+-- > upgraded :: Property DebianLike
+-- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
+tightenTargets
+	:: 
+		-- Note that this uses PolyKinds
+		( (Targets old `NotSuperset` Targets new) ~ CanCombineTargets
+		, (NonTargets new `NotSuperset` NonTargets old) ~ CanCombineTargets
+		, SingI new
+		)
+	=> Property (Sing old)
+	-> Property (Sing new)
+tightenTargets (Property old d a i c) = Property sing d a i c
+
+{-
+
+-- | Picks one of the two input properties to use,
+-- depending on the targeted OS.
+--
+-- If both input properties support the targeted OS, then the
+-- first will be used.
+pickOS
+	::
+		( combined ~ Union a b
+		, SingI combined
+		)
+	=> Property (Sing a)
+	-> Property (Sing b)
+	-> Property (Sing combined)
+pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io
+  where
+	-- TODO pick with of ioa or iob to use based on final OS of
+	-- system being run on.
+	io = undefined
+
+-}
+
 -- | Makes a property that is satisfied differently depending on the host's
 -- operating system. 
 --
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 382f5d9d..46f5cef3 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -2,13 +2,14 @@ module Propellor.Property.Network where
 
 import Propellor.Base
 import Propellor.Property.File
+import Propellor.Types.MetaTypes
 
 import Data.Char
 
 type Interface = String
 
-ifUp :: Interface -> Property NoInfo
-ifUp iface = cmdProperty "ifup" [iface]
+ifUp :: Interface -> Property DebianLike
+ifUp iface = tightenTargets $ cmdProperty "ifup" [iface]
 	`assume` MadeChange
 
 -- | Resets /etc/network/interfaces to a clean and empty state,
@@ -18,8 +19,8 @@ ifUp iface = cmdProperty "ifup" [iface]
 -- This can be used as a starting point to defining other interfaces.
 --
 -- No interfaces are brought up or down by this property.
-cleanInterfacesFile :: Property NoInfo
-cleanInterfacesFile = hasContent interfacesFile
+cleanInterfacesFile :: Property DebianLike
+cleanInterfacesFile = tightenTargets $ hasContent interfacesFile
 	[ "# Deployed by propellor, do not edit."
 	, ""
 	, "source-directory interfaces.d"
@@ -31,8 +32,8 @@ cleanInterfacesFile = hasContent interfacesFile
 	`describe` ("clean " ++ interfacesFile)
 
 -- | Configures an interface to get its address via dhcp.
-dhcp :: Interface -> Property NoInfo
-dhcp iface = hasContent (interfaceDFile iface)
+dhcp :: Interface -> Property DebianLike
+dhcp iface = tightenTargets $ hasContent (interfaceDFile iface)
 	[ "auto " ++ iface
 	, "iface " ++ iface ++ " inet dhcp"
 	]
@@ -50,18 +51,20 @@ dhcp iface = hasContent (interfaceDFile iface)
 --
 -- (ipv6 addresses are not included because it's assumed they come up
 -- automatically in most situations.)
-static :: Interface -> Property NoInfo
-static iface = check (not <$> doesFileExist f) setup
-	`describe` desc
-	`requires` interfacesDEnabled
+static :: Interface -> Property DebianLike
+static iface = tightenTargets $ 
+	check (not <$> doesFileExist f) setup
+		`describe` desc
+		`requires` interfacesDEnabled
   where
 	f = interfaceDFile iface
 	desc = "static " ++ iface
-	setup = property desc $ do
+	setup :: Property DebianLike
+	setup = property' desc $ \o -> do
 		ls <- liftIO $ lines <$> readProcess "ip"
 			["-o", "addr", "show", iface, "scope", "global"]
 		stanzas <- liftIO $ concat <$> mapM mkstanza ls
-		ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas
+		ensureProperty o $ hasContent f $ ("auto " ++ iface) : stanzas
 	mkstanza ipline = case words ipline of
 		-- Note that the IP address is written CIDR style, so
 		-- the netmask does not need to be specified separately.
@@ -81,8 +84,8 @@ static iface = check (not <$> doesFileExist f) setup
 			_ -> Nothing
 
 -- | 6to4 ipv6 connection, should work anywhere
-ipv6to4 :: Property NoInfo
-ipv6to4 = hasContent (interfaceDFile "sit0")
+ipv6to4 :: Property DebianLike
+ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0")
 	[ "# Deployed by propellor, do not edit."
 	, "iface sit0 inet6 static"
 	, "\taddress 2002:5044:5531::1"
@@ -107,6 +110,8 @@ escapeInterfaceDName :: Interface -> FilePath
 escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-"))
 
 -- | Ensures that files in the the interfaces.d directory are used.
-interfacesDEnabled :: Property NoInfo
-interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
-	`describe` "interfaces.d directory enabled"
+-- interfacesDEnabled :: Property DebianLike
+interfacesDEnabled :: Property DebianLike
+interfacesDEnabled = tightenTargets $
+	containsLine interfacesFile "source-directory interfaces.d"
+		`describe` "interfaces.d directory enabled"
-- 
cgit v1.3-2-g0d8e


From 91d1833155a2e8be2c435d0a92a750cc9d2f30b5 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 25 Mar 2016 14:04:40 -0400
Subject: ported Property.List

I wanted to keep propertyList [foo, bar] working, but had some difficulty
making the type class approach work. Anyway, that's unlikely to be useful,
since foo and bar probably have different types, or could easiy have their
types updated breaking it.
---
 debian/changelog                     |  34 +++++++-----
 src/Propellor/Base.hs                |   4 +-
 src/Propellor/Engine.hs              |  16 ++++--
 src/Propellor/EnsureProperty.hs      |   2 +-
 src/Propellor/PrivData.hs            |   2 +-
 src/Propellor/PropAccum.hs           |   9 +--
 src/Propellor/Property.hs            |   4 +-
 src/Propellor/Property/Chroot.hs     |   2 +-
 src/Propellor/Property/Concurrent.hs |   4 +-
 src/Propellor/Property/Docker.hs     |   2 +-
 src/Propellor/Property/List.hs       | 104 ++++++++++++-----------------------
 src/Propellor/Types.hs               |  20 ++++---
 12 files changed, 93 insertions(+), 110 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index ead6585e..b27559bd 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,37 +1,43 @@
 propellor (3.0.0) UNRELEASED; urgency=medium
 
   * Property types have been improved to indicate what systems they target.
-    This allows, eg, Property Debian to not be used on a FreeBSD system.
+    This prevents using eg, Property FreeBSD on a Debian system.
     Transition guide for this sweeping API change:
+    - Change "host name & foo & bar"
+      to     "host name $ props & foo & bar"
+    - Similarly, Chroot and Docker need `props` to be used to combine
+      together the properies used inside them.
+    - And similarly, `propertyList` and `combineProperties` need `props`
+      to be used to combine together properties; lists of properties will
+      no longer work.
     - Change "Property NoInfo" to "Property UnixLike"
     - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"
     - Change "RevertableProperty NoInfo" to
       "RevertableProperty UnixLike UnixLike"
     - Change "RevertableProperty HasInfo" to
       "RevertableProperty (HasInfo + UnixLike) UnixLike"
-    - GHC needs {-# LANGUAGE TypeOperators #-} to use these new type signatures.
+    - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types.
       This is enabled by default for all modules in propellor.cabal. But
       if you are using propellor as a library, you may need to enable it
       manually.
     - If you know a property only works on a particular OS, like Debian
       or FreeBSD, use that instead of "UnixLike". For example:
-      "Property (HasInfo + Debian)"
+      "Property Debian"
     - It's also possible make a property support a set of OS's, for example:
-      "Property (HasInfo + Debian + FreeBSD)"
-    - `ensureProperty` now needs information about the metatypes of the
-      property it's used in to be passed to it. See the documentation
-      of `ensureProperty` for an example, but basically, change
-      this:     foo = property desc $ ... ensureProperty bar
-      to this:  foo = property' desc $ \o -> ... ensureProperty o bar
+      "Property (Debian + FreeBSD)"
+    - `ensureProperty` now needs to be passed information about the
+      property it's used in.
+      change this:  foo = property desc $ ... ensureProperty bar
+      to this:      foo = property' desc $ \o -> ... ensureProperty o 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 targets to only the OS that your more specific
-      property works on. For example:
+      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"])
-    - 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.
+  * 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.
 
  -- Joey Hess <id@joeyh.name>  Thu, 24 Mar 2016 15:02:33 -0400
 
diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs
index e50adf10..4afad2ab 100644
--- a/src/Propellor/Base.hs
+++ b/src/Propellor/Base.hs
@@ -9,7 +9,7 @@ module Propellor.Base (
 	, module Propellor.Property.Cmd
 	--, module Propellor.Property.List
 	, module Propellor.Types.PrivData
-	--, module Propellor.PropAccum
+	, module Propellor.PropAccum
 	, module Propellor.Info
 	, module Propellor.PrivData
 	--, module Propellor.Engine
@@ -43,7 +43,7 @@ import Propellor.Message
 import Propellor.Debug
 import Propellor.Exception
 import Propellor.Info
---import Propellor.PropAccum
+import Propellor.PropAccum
 import Propellor.Location
 import Propellor.Utilities
 
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 2e914d67..62fad5af 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -2,10 +2,10 @@
 {-# LANGUAGE GADTs #-}
 
 module Propellor.Engine (
-	mainProperties,
+	-- mainProperties,
 	runPropellor,
 	ensureProperty,
-	ensureProperties,
+	ensureChildProperties,
 	fromHost,
 	fromHost',
 	onlyProcess,
@@ -29,6 +29,8 @@ import Propellor.Info
 import Propellor.Property
 import Utility.Exception
 
+{-
+
 -- | Gets the Properties of a Host, and ensures them all,
 -- with nice display of what's being done.
 mainProperties :: Host -> IO ()
@@ -42,6 +44,8 @@ mainProperties host = do
   where
 	ps = map ignoreInfo $ hostProperties host
 
+-}
+
 -- | Runs a Propellor action with the specified host.
 --
 -- If the Result is not FailedChange, any EndActions
@@ -58,14 +62,14 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
 	(ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host ()
 	return ret
 
--- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property NoInfo] -> Propellor Result
-ensureProperties ps = ensure ps NoChange
+-- | Ensures the child properties, with a display of each as it runs.
+ensureChildProperties :: [ChildProperty] -> Propellor Result
+ensureChildProperties ps = ensure ps NoChange
   where
 	ensure [] rs = return rs
 	ensure (p:ls) rs = do
 		hn <- asks hostName
-		r <- actionMessageOn hn (propertyDesc p) (ensureProperty p)
+		r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p)
 		ensure ls (r <> rs)
 
 -- | Lifts an action into the context of a different host.
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index f42003c0..21f8acce 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -39,7 +39,7 @@ ensureProperty
 	=> OuterMetaTypes outer
 	-> Property (MetaTypes inner)
 	-> Propellor Result
-ensureProperty _ = catchPropellor . propertySatisfy
+ensureProperty _ = catchPropellor . getSatisfy
 
 -- The name of this was chosen to make type errors a more understandable.
 type family CannotUse_ensureProperty_WithInfo (l :: [a]) :: Bool
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index bc61c538..5e6e0869 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -129,7 +129,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 		return FailedChange
 	addinfo p = Property undefined -- FIXME: should use sing here
 		(propertyDesc p)
-		(propertySatisfy p)
+		(getSatisfy p)
 		(propertyInfo p `addInfo` privset)
 		(propertyChildren p)
 	privset = PrivInfo $ S.fromList $
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index fb38e260..8177b97b 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -36,8 +36,9 @@ host hn (Props i c) = Host hn c i
 -- metatypes and info.
 data Props metatypes = Props Info [ChildProperty]
 
--- | Start constructing a Props. Properties can then be added to it using
--- `(&)` etc.
+-- | Start accumulating a list of properties.
+--
+-- Properties can be added to it using `(&)` etc.
 props :: Props UnixLike
 props = Props mempty []
 
@@ -102,7 +103,7 @@ propagateContainer
 propagateContainer containername c prop = Property
 	undefined
 	(propertyDesc prop)
-	(propertySatisfy prop)
+	(getSatisfy prop)
 	(propertyInfo prop)
 	(propertyChildren prop ++ hostprops)
   where
@@ -111,6 +112,6 @@ propagateContainer containername c prop = Property
 		let i = mapInfo (forceHostContext containername)
 			(propagatableInfo (propertyInfo p))
 		    cs = map go (propertyChildren p)
-		in infoProperty (propertyDesc p) (propertySatisfy p) i cs
+		in infoProperty (propertyDesc p) (getSatisfy p) i cs
 
 -}
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 582b7cfb..8999d8d8 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -255,8 +255,8 @@ isNewerThan x y = do
 tightenTargets
 	:: 
 		-- Note that this uses PolyKinds
-		( (Targets old `NotSuperset` Targets new) ~ 'CanCombineTargets
-		, (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombineTargets
+		( (Targets old `NotSuperset` Targets new) ~ 'CanCombine
+		, (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombine
 		, SingI new
 		)
 	=> Property (MetaTypes old)
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 378836e8..fb05d659 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -148,7 +148,7 @@ propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
   where
 	p' = infoProperty
 		(propertyDesc p)
-		(propertySatisfy p)
+		(getSatisfy p)
 		(propertyInfo p <> chrootInfo c)
 		(propertyChildren p)
 
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index 74afecc4..8d608a54 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -97,7 +97,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps
 			(p:rest) -> return (rest, Just p)
 		case v of
 			Nothing -> return r
-			-- This use of propertySatisfy does not lose any
+			-- This use of getSatisfy does not lose any
 			-- Info asociated with the property, because
 			-- concurrentList sets all the properties as
 			-- children, and so propigates their info.
@@ -105,7 +105,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps
 				hn <- asks hostName
 				r' <- actionMessageOn hn
 					(propertyDesc p)
-					(propertySatisfy p)
+					(getSatisfy p)
 				worker q (r <> r')
 
 -- | Run an action with the number of capabiities increased as necessary to
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index ebc0b301..c2c131c7 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -178,7 +178,7 @@ propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
   where
 	p' = infoProperty
 		(propertyDesc p)
-		(propertySatisfy p)
+		(getSatisfy p)
 		(propertyInfo p <> dockerinfo)
 		(propertyChildren p)
 	dockerinfo = dockerInfo $
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 74aa6ca6..b4a72fa8 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -1,86 +1,54 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Propellor.Property.List (
 	props,
-	PropertyList(..),
-	PropertyListType,
-	PropList(..),
+	Props,
+	propertyList,
+	combineProperties,
 ) where
 
 import Propellor.Types
+import Propellor.Types.MetaTypes
 import Propellor.Engine
 import Propellor.PropAccum
+import Propellor.Exception
 
 import Data.Monoid
 
--- | Starts accumulating a list of properties.
+-- | Combines a list of properties, resulting in a single property
+-- that when run will run each property in the list in turn,
+-- and print out the description of each as it's run. Does not stop
+-- on failure; does propagate overall success/failure.
+--
+-- For example:
 --
 -- > propertyList "foo" $ props
--- > 	& someproperty
--- > 	! oldproperty
--- > 	& otherproperty
-props :: PropList
-props = PropList []
-
-data PropList = PropList [Property HasInfo]
-
-instance PropAccum PropList where
-	PropList l `addProp` p = PropList (toProp p : l)
-	PropList l `addPropFront` p = PropList (l ++ [toProp p])
-	getProperties (PropList l) = reverse l
-
-class PropertyList l where
-	-- | Combines a list of properties, resulting in a single property
-	-- that when run will run each property in the list in turn,
-	-- and print out the description of each as it's run. Does not stop
-	-- on failure; does propagate overall success/failure.
-	--
-	-- Note that Property HasInfo and Property NoInfo are not the same
-	-- type, and so cannot be mixed in a list. To make a list of
-	-- mixed types, which can also include RevertableProperty,
-	-- use `props`
-	propertyList :: Desc -> l -> Property (PropertyListType l)
-
-	-- | Combines a list of properties, resulting in one property that
-	-- ensures each in turn. Stops if a property fails.
-	combineProperties :: Desc -> l -> Property (PropertyListType l)
-
--- | Type level function to calculate whether a PropertyList has Info.
-type family PropertyListType t
-type instance PropertyListType [Property HasInfo] = HasInfo
-type instance PropertyListType [Property NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty HasInfo] = HasInfo
-type instance PropertyListType PropList = HasInfo
-
-instance PropertyList [Property NoInfo] where
-	propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
-	combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
-
-instance PropertyList [Property HasInfo] where
-	-- It's ok to use ignoreInfo here, because the ps are made the
-	-- child properties of the property, and so their info is visible
-	-- that way.
-	propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
-	combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
-
-instance PropertyList [RevertableProperty HasInfo] where
-	propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
-	combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList [RevertableProperty NoInfo] where
-	propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
-	combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList PropList where
-	propertyList desc = propertyList desc . getProperties
-	combineProperties desc = combineProperties desc . getProperties
-
-combineSatisfy :: [Property i] -> Result -> Propellor Result
+-- > 	& bar
+-- > 	& baz
+propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+propertyList desc (Props _i ps) = 
+	property desc (ensureChildProperties cs)
+		`modifyChildren` (++ cs)
+  where
+	cs = map toProp ps
+
+-- | Combines a list of properties, resulting in one property that
+-- ensures each in turn. Stops if a property fails.
+combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+combineProperties desc (Props _i ps) = 
+	property desc (combineSatisfy cs NoChange)
+		`modifyChildren` (++ cs)
+  where
+	cs = map toProp ps
+
+combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
 combineSatisfy [] rs = return rs
-combineSatisfy (l:ls) rs = do
-	r <- ensureProperty $ ignoreInfo l
+combineSatisfy (p:ps) rs = do
+	r <- catchPropellor $ getSatisfy p
 	case r of
 		FailedChange -> return FailedChange
-		_ -> combineSatisfy ls (r <> rs)
+		_ -> combineSatisfy ps (r <> rs)
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 42c12492..db05e100 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -14,6 +14,7 @@ module Propellor.Types
 	, Info
 	, Desc
 	, MetaType(..)
+	, MetaTypes
 	, OS(..)
 	, UnixLike
 	, Debian
@@ -41,8 +42,6 @@ module Propellor.Types
 	, module Propellor.Types.Dns
 	, module Propellor.Types.Result
 	, module Propellor.Types.ZFS
-	, propertySatisfy
-	, MetaTypes
 	) where
 
 import Data.Monoid
@@ -169,12 +168,6 @@ ignoreInfo =
 
 -}
 
--- | Gets the action that can be run to satisfy a Property.
--- You should never run this action directly. Use
--- 'Propellor.EnsureProperty.ensureProperty` instead.
-propertySatisfy :: Property metatypes -> Propellor Result
-propertySatisfy (Property _ _ a _ _) = a
-
 -- | 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
@@ -214,34 +207,45 @@ setup <!> undo = RevertableProperty setup undo
 class IsProp p where
 	setDesc :: p -> Desc -> p
 	getDesc :: p -> Desc
+	modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p
 	-- | Gets the info of the property, combined with all info
 	-- of all children properties.
 	getInfoRecursive :: p -> Info
 	toProp :: p -> ChildProperty
+	-- | Gets the action that can be run to satisfy a Property.
+	-- You should never run this action directly. Use
+	-- 'Propellor.EnsureProperty.ensureProperty` instead.
+	getSatisfy :: p -> Propellor Result
 
 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)
 	getInfoRecursive (Property _ _ _ i c) =
 		i <> mconcat (map getInfoRecursive c)
 	toProp (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)
 	getInfoRecursive (ChildProperty _ _ i c) =
 		i <> mconcat (map getInfoRecursive c)
 	toProp = id
+	getSatisfy (ChildProperty _ a _ _) = a
 
 instance IsProp (RevertableProperty setupmetatypes undometatypes) where
 	-- | Sets the description of both sides.
 	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)
 	-- toProp (RevertableProperty p1 _) = p1
 	-- | Return the Info of the currently active side.
 	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
 	toProp (RevertableProperty p1 _p2) = toProp p1
+	getSatisfy (RevertableProperty p1 _) = getSatisfy p1
 
 -- | Type level calculation of the type that results from combining two
 -- types of properties.
-- 
cgit v1.3-2-g0d8e


From 2962f5c783db7a0f7014a8745768948c15d6a8ea Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 26 Mar 2016 13:50:38 -0400
Subject: fixed type checking of Ssh

---
 debian/changelog              | 12 +++++++++
 src/Propellor/Property/Ssh.hs | 61 +++++++++++++++++++++++++------------------
 2 files changed, 48 insertions(+), 25 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index b27559bd..1bbc1f0e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -25,6 +25,18 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       "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 information about the
       property it's used in.
       change this:  foo = property desc $ ... ensureProperty bar
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 12c06919..dc4b7a75 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -155,18 +155,21 @@ type PubKeyText = String
 --
 -- Any host keys that are not in the list are removed from the host.
 hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike)
-hostKeys ctx l = propertyList desc $ toProps $ catMaybes $
-	map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
+hostKeys ctx l = go `before` cleanup
   where
 	desc = "ssh host keys configured " ++ typelist (map fst l)
+	go :: Property (HasInfo + DebianLike)
+	go = propertyList desc $ toProps $ catMaybes $
+		map (\(t, pub) -> Just $ hostKey ctx t pub) l
 	typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")"
 	alltypes = [minBound..maxBound]
 	staletypes = let have = map fst l in filter (`notElem` have) alltypes
-	removestale b = map (File.notPresent . flip keyFile b) staletypes
-	cleanup :: Maybe (Property DebianLike)
+	removestale :: Bool -> [Property DebianLike]
+	removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
+	cleanup :: Property DebianLike
 	cleanup
-		| null staletypes || null l = Nothing
-		| otherwise = Just $
+		| null staletypes || null l = tightenTargets doNothing
+		| otherwise =
 			combineProperties ("any other ssh host keys removed " ++ typelist staletypes)
 				(toProps $ removestale True ++ removestale False)
 				`onChange` restarted
@@ -176,23 +179,26 @@ hostKeys ctx l = propertyList desc $ toProps $ catMaybes $
 -- The public key is provided to this function;
 -- the private key comes from the privdata;
 hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike)
-hostKey context keytype pub = combineProperties desc (props
-	& hostPubKey keytype pub
-	& installpub
-	& installpriv
-	) `onChange` restarted
+hostKey context keytype pub = go `onChange` restarted
   where
+	go = combineProperties desc $ props
+		& hostPubKey keytype pub
+		& installpub
+		& installpriv
 	desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
-	install w writer ispub keylines = do
-		let f = keyFile keytype ispub
-		ensureProperty w $ writer f (keyFileContent keylines)
 	keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
 		("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
-	installpub = property' desc $ \w -> install w File.hasContent True (lines pub)
+	installpub :: Property UnixLike
+	installpub = keywriter File.hasContent True (lines pub)
+	installpriv :: Property (HasInfo + UnixLike)
 	installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
 		property' desc $ \w -> getkey $
-			install w File.hasContentProtected False . privDataLines
-
+			ensureProperty w
+				. keywriter File.hasContentProtected False
+				. privDataLines
+	keywriter p ispub keylines = do
+		let f = keyFile keytype ispub
+		p f (keyFileContent keylines)
 
 -- Make sure that there is a newline at the end;
 -- ssh requires this for some types of private keys.
@@ -207,7 +213,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
 -- | Indicates the host key that is used by a Host, but does not actually
 -- configure the host to use it. Normally this does not need to be used;
 -- use 'hostKey' instead.
-hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike)
+hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + UnixLike)
 hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t
 
 getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
@@ -279,13 +285,18 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) =
 		, dest
 		, Just $ "(" ++ fromKeyType keytype ++ ")"
 		]
-	pubkey = property' desc $ \w -> install w File.hasContent ".pub" [pubkeytext]
-	privkey = withPrivData (SshPrivKey keytype u) context $ \getkey ->
-		property' desc $ \w -> getkey $
-			install w File.hasContentProtected "" . privDataLines
-	install w writer ext key = do
+	pubkey :: Property UnixLike
+	pubkey = property' desc $ \w -> 
+		ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext]
+	privkey :: Property (HasInfo + UnixLike)
+	privkey = withPrivData (SshPrivKey keytype u) context privkey'
+	privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike)
+	privkey' getkey = property' desc $ \w -> getkey $ \k ->
+		ensureProperty w
+			=<< installprop File.hasContentProtected "" (privDataLines k)
+	installprop writer ext key = do
 		f <- liftIO $ keyfile ext
-		ensureProperty w $ combineProperties desc $ props
+		return $ combineProperties desc $ props
 			& writer f (keyFileContent key)
 			& File.ownerGroup f user (userGroup user)
 			& File.ownerGroup (takeDirectory f) user (userGroup user)
@@ -325,7 +336,7 @@ unknownHost hosts hn user@(User u) = property' desc $ \w ->
   where
 	desc = u ++ " does not know ssh key for " ++ hn
 
-	go w [] = return NoChange
+	go _ [] = return NoChange
 	go w ls = do
 		f <- liftIO $ dotFile "known_hosts" user
 		ifM (liftIO $ doesFileExist f)
-- 
cgit v1.3-2-g0d8e


From 341064ea8cfaeb04ec4129239edc096a314de036 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 26 Mar 2016 15:03:56 -0400
Subject: more porting

---
 debian/changelog                 |  8 ++++----
 src/Propellor/Property/OS.hs     | 43 +++++++++++++++++++++++++---------------
 src/Propellor/Property/OpenId.hs |  6 +++---
 src/Propellor/Property/Reboot.hs |  6 +++---
 4 files changed, 37 insertions(+), 26 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index 1bbc1f0e..562eccd7 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -5,11 +5,11 @@ propellor (3.0.0) UNRELEASED; urgency=medium
     Transition guide for this sweeping API change:
     - Change "host name & foo & bar"
       to     "host name $ props & foo & bar"
-    - Similarly, Chroot and Docker need `props` to be used to combine
+    - 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 and Docker need `props` to be used to combine
       together the properies used inside them.
-    - And similarly, `propertyList` and `combineProperties` need `props`
-      to be used to combine together properties; lists of properties will
-      no longer work.
     - Change "Property NoInfo" to "Property UnixLike"
     - Change "Property HasInfo" to "Property (HasInfo + UnixLike)"
     - Change "RevertableProperty NoInfo" to
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index e5da0921..42504453 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -64,7 +64,7 @@ import Control.Exception (throw)
 -- > & User.accountFor "joey"
 -- > & User.hasSomePassword "joey"
 -- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property NoInfo
+cleanInstallOnce :: Confirmation -> Property Linux
 cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 	go `requires` confirmed "clean install confirmed" confirmation
   where
@@ -83,12 +83,16 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 			`requires`
 		osbootstrapped
 
-	osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of
-		(Just d@(System (Debian _) _)) -> debootstrap d
-		(Just u@(System (Buntish _) _)) -> debootstrap u
+	osbootstrapped :: Property Linux
+	osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of
+		(Just d@(System (Debian _) _)) -> ensureProperty w $
+			debootstrap d
+		(Just u@(System (Buntish _) _)) -> ensureProperty w $
+			debootstrap u
 		_ -> unsupportedOS
 	
-	debootstrap targetos = ensureProperty $
+	debootstrap :: System -> Property Linux
+	debootstrap targetos =
 		-- Ignore the os setting, and install debootstrap from
 		-- source, since we don't know what OS we're running in yet.
 		Debootstrap.built' Debootstrap.sourceInstall
@@ -100,6 +104,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 		-- sync instead?
 
 	-- This is the fun bit.
+	flipped :: Property Linux
 	flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
 		-- First, unmount most mount points, lazily, so
 		-- they don't interfere with moving things around.
@@ -137,6 +142,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 
 		return MadeChange
 
+	propellorbootstrapped :: Property UnixLike
 	propellorbootstrapped = property "propellor re-debootstrapped in new os" $
 		return NoChange
 		-- re-bootstrap propellor in /usr/local/propellor,
@@ -145,6 +151,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 		--   be present in /old-os's /usr/local/propellor)
 		-- TODO
 	
+	finalized :: Property UnixLike
 	finalized = property "clean OS installed" $ do
 		liftIO $ writeFile flagfile ""
 		return MadeChange
@@ -179,7 +186,7 @@ massRename = go []
 
 data Confirmation = Confirmed HostName
 
-confirmed :: Desc -> Confirmation -> Property NoInfo
+confirmed :: Desc -> Confirmation -> Property UnixLike
 confirmed desc (Confirmed c) = property desc $ do
 	hostname <- asks hostName
 	if hostname /= c
@@ -191,25 +198,26 @@ confirmed desc (Confirmed c) = property desc $ do
 -- | </etc/network/interfaces> is configured to bring up the network 
 -- interface that currently has a default route configured, using
 -- the same (static) IP address.
-preserveNetwork :: Property NoInfo
+preserveNetwork :: Property DebianLike
 preserveNetwork = go `requires` Network.cleanInterfacesFile
   where
-	go = property "preserve network configuration" $ do
+	go :: Property DebianLike
+	go = property' "preserve network configuration" $ \w -> do
 		ls <- liftIO $ lines <$> readProcess "ip"
 			["route", "list", "scope", "global"]
 		case words <$> headMaybe ls of
 			Just ("default":"via":_:"dev":iface:_) ->
-				ensureProperty $ Network.static iface
+				ensureProperty w $ Network.static iface
 			_ -> do
 				warningMessage "did not find any default ipv4 route"
 				return FailedChange 
 
 -- | </etc/resolv.conf> is copied from the old OS
-preserveResolvConf :: Property NoInfo
+preserveResolvConf :: Property Linux
 preserveResolvConf = check (fileExist oldloc) $
-	property (newloc ++ " copied from old OS") $ do
+	property' (newloc ++ " copied from old OS") $ \w -> do
 		ls <- liftIO $ lines <$> readFile oldloc
-		ensureProperty $ newloc `File.hasContent` ls
+		ensureProperty w $ newloc `File.hasContent` ls
   where
 	newloc = "/etc/resolv.conf"
 	oldloc = oldOSDir ++ newloc
@@ -217,20 +225,23 @@ preserveResolvConf = check (fileExist oldloc) $
 -- | </root/.ssh/authorized_keys> has added to it any ssh keys that
 -- were authorized in the old OS. Any other contents of the file are
 -- retained.
-preserveRootSshAuthorized :: Property NoInfo
+preserveRootSshAuthorized :: Property UnixLike
 preserveRootSshAuthorized = check (fileExist oldloc) $
-	property (newloc ++ " copied from old OS") $ do
+	property' desc $ \w -> do
 		ks <- liftIO $ lines <$> readFile oldloc
-		ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks)
+		ensureProperty w $ combineProperties desc $
+			toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks
   where
+	desc = newloc ++ " copied from old OS"
 	newloc = "/root/.ssh/authorized_keys"
 	oldloc = oldOSDir ++ newloc
 
 -- Removes the old OS's backup from </old-os>
-oldOSRemoved :: Confirmation -> Property NoInfo
+oldOSRemoved :: Confirmation -> Property UnixLike
 oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
 	go `requires` confirmed "old OS backup removal confirmed" confirmation
   where
+	go :: Property UnixLike
 	go = property "old OS backup removed" $ do
 		liftIO $ removeDirectoryRecursive oldOSDir
 		return MadeChange
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index 0f73bfb6..0abf38a6 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -16,7 +16,7 @@ import Data.List
 --
 -- It's probably a good idea to put this property inside a docker or
 -- systemd-nspawn container.
-providerFor :: [User] -> HostName -> Maybe Port -> Property HasInfo
+providerFor :: [User] -> HostName -> Maybe Port -> Property (HasInfo + DebianLike)
 providerFor users hn mp = propertyList desc $ props
 	& Apt.serviceInstalledRunning "apache2"
 	& apacheconfigured
@@ -24,7 +24,7 @@ providerFor users hn mp = propertyList desc $ props
 		`onChange` Apache.restarted
 	& File.fileProperty (desc ++ " configured")
 		(map setbaseurl) "/etc/simpleid/config.inc"
-	& propertyList desc (map identfile users)
+	& propertyList desc (toProps $ map identfile users)
   where
 	baseurl = hn ++ case mp of
 		Nothing -> ""
@@ -37,7 +37,7 @@ providerFor users hn mp = propertyList desc $ props
 		| otherwise = l
 
 	apacheconfigured = case mp of
-		Nothing -> toProp $
+		Nothing -> setupRevertableProperty $
 			Apache.virtualHost hn (Port 80) "/var/www/html"
 		Just p -> propertyList desc $ props
 			& Apache.listenPorts [p]
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 26b85840..5b854fa3 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -2,8 +2,8 @@ module Propellor.Property.Reboot where
 
 import Propellor.Base
 
-now :: Property NoInfo
-now = cmdProperty "reboot" []
+now :: Property Linux
+now = tightenTargets $ cmdProperty "reboot" []
 	`assume` MadeChange
 	`describe` "reboot now"
 
@@ -14,7 +14,7 @@ now = cmdProperty "reboot" []
 --
 -- The reboot can be forced to run, which bypasses the init system. Useful
 -- if the init system might not be running for some reason.
-atEnd :: Bool -> (Result -> Bool) -> Property NoInfo
+atEnd :: Bool -> (Result -> Bool) -> Property Linux
 atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
 	endAction "rebooting" atend
 	return NoChange
-- 
cgit v1.3-2-g0d8e


From e4ac94860bcc4511370e878e14ef9d45b60aeb2a Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
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 'debian')

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
+-- <http://joeyh.name/blog/entry/trademark_nonsense/>)
+osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish)
+osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)
+
+-- | Specifies that a host's operating system is FreeBSD
+-- and further indicates the release and architecture.
+osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
+osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)
+
 os :: System -> Property (HasInfo + UnixLike)
 os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)
 
@@ -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 <joeyh@joeyh.name>
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 'debian')

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: <https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection>)
-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 </usr/sbin/policy-rc.d> script
 -- that does not let any daemons be started by packages that use
 -- invoke-rc.d. Reverting the property removes the script.
-noServices :: RevertableProperty NoInfo
+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 </etc/resolv.conf> 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 f69e185f99394b658f14f9d62a8fb55f7d179d30 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 27 Mar 2016 17:28:17 -0400
Subject: ported

fixed up chroot to take Props
---
 debian/changelog                                   |   4 +-
 joeyconfig.hs                                      |   8 +-
 src/Propellor/Property/Chroot.hs                   |  10 +-
 .../Property/SiteSpecific/GitAnnexBuilder.hs       | 103 +++++++++++----------
 src/Propellor/Property/Systemd.hs                  |   5 +-
 5 files changed, 66 insertions(+), 64 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index 8a5b67e4..fc499c86 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -8,8 +8,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium
     - 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 and Docker need `props` to be used to combine
-      together the properies used inside them.
+    - And similarly, Chroot, Docker, and Systemd container need `props`
+      to be used to combine together the properies used inside them.
     - The `os` property is removed. Instead use `osDebian`, `osBuntish`,
       or `osFreeBSD`. These tell the type checker the target OS of a host.
     - Change "Property NoInfo" to "Property UnixLike"
diff --git a/joeyconfig.hs b/joeyconfig.hs
index 327c268e..036c7b61 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -190,13 +190,13 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
 
 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
 		GitAnnexBuilder.standardAutoBuilder
-		(System (Debian Unstable) "amd64") Nothing (Cron.Times "15 * * * *") "2h")
+		Unstable "amd64" Nothing (Cron.Times "15 * * * *") "2h")
 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
 		GitAnnexBuilder.standardAutoBuilder
-		(System (Debian Unstable) "i386") Nothing (Cron.Times "30 * * * *") "2h")
+		Unstable "i386") Nothing (Cron.Times "30 * * * *") "2h")
 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
 		GitAnnexBuilder.stackAutoBuilder
-		(System (Debian (Stable "jessie")) "i386") (Just "ancient") (Cron.Times "45 * * * *") "2h")
+		(Stable "jessie") "i386" (Just "ancient") (Cron.Times "45 * * * *") "2h")
 	& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer
 		(Cron.Times "1 1 * * *") "3h")
 
@@ -229,7 +229,7 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
 
 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
 		GitAnnexBuilder.armAutoBuilder
-			(System (Debian Unstable) "armel") Nothing Cron.Daily "22h")
+			Unstable "armel" Nothing Cron.Daily "22h")
 
 -- This is not a complete description of kite, since it's a
 -- multiuser system with eg, user passwords that are not deployed
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index b29da7f9..811b5baa 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -103,19 +103,17 @@ instance ChrootBootstrapper Debootstrapped where
 -- add a property such as `osDebian` to specify the operating system
 -- to bootstrap.
 --
--- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
 -- >	& osDebian Unstable "amd64"
 -- >	& Apt.installed ["ghc", "haskell-platform"]
 -- >	& ...
-debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
 debootstrapped conf = bootstrapped (Debootstrapped conf)
 
 -- | Defines a Chroot at the given location, bootstrapped with the
 -- specified ChrootBootstrapper.
-bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot
-bootstrapped bootstrapper location = Chroot location bootstrapper h
-  where
-	h = Host location [] mempty
+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
+bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)
 
 -- | Ensures that the chroot exists and is provisioned according to its
 -- properties.
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 2932baf7..d2c6db3c 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -25,7 +25,7 @@ builddir = gitbuilderdir </> "build"
 
 type TimeOut = String -- eg, 5h
 
-autobuilder :: Architecture -> Times -> TimeOut -> Property HasInfo
+autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike)
 autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
 	& Apt.serviceInstalledRunning "cron"
 	& Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir
@@ -37,6 +37,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
 	-- The builduser account does not have a password set,
 	-- instead use the password privdata to hold the rsync server
 	-- password used to upload the built image.
+	rsyncpassword :: Property (HasInfo + DebianLike)
 	rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
 		property "rsync password" $ getpw $ \pw -> do
 			have <- liftIO $ catchDefaultIO "" $
@@ -46,7 +47,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
 				then makeChange $ writeFile pwfile want
 				else noChange
 
-tree :: Architecture -> Flavor -> Property HasInfo
+tree :: Architecture -> Flavor -> Property DebianLike
 tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
 	& Apt.installed ["git"]
 	& File.dirExists gitbuilderdir
@@ -66,14 +67,14 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
 		[ "git clone git://git-annex.branchable.com/ " ++ builddir
 		]
 
-buildDepsApt :: Property HasInfo
+buildDepsApt :: Property DebianLike
 buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
 	& Apt.buildDep ["git-annex"]
 	& buildDepsNoHaskellLibs
 	& Apt.buildDepIn builddir
 		`describe` "git-annex source build deps installed"
 
-buildDepsNoHaskellLibs :: Property NoInfo
+buildDepsNoHaskellLibs :: Property DebianLike
 buildDepsNoHaskellLibs = Apt.installed
 	["git", "rsync", "moreutils", "ca-certificates",
 	"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",
@@ -83,8 +84,9 @@ buildDepsNoHaskellLibs = Apt.installed
 	"libmagic-dev", "alex", "happy", "c2hs"
 	]
 
-haskellPkgsInstalled :: String -> Property NoInfo
-haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
+haskellPkgsInstalled :: String -> Property DebianLike
+haskellPkgsInstalled dir = tightenTargets $ 
+	flagFile go ("/haskellpkgsinstalled")
   where
 	go = userScriptProperty (User builduser)
 		[ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages"
@@ -93,7 +95,7 @@ haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
 
 -- Installs current versions of git-annex's deps from cabal, but only
 -- does so once.
-cabalDeps :: Property NoInfo
+cabalDeps :: Property UnixLike
 cabalDeps = flagFile go cabalupdated
 	where
 		go = userScriptProperty (User builduser)
@@ -101,20 +103,20 @@ cabalDeps = flagFile go cabalupdated
 			`assume` MadeChange
 		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
 
-autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container
-autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout =
-	Systemd.container name osver (Chroot.debootstrapped mempty)
-		& mkprop osver flavor
+autoBuilderContainer :: DebianSuite -> Architecture -> Flavor -> Times -> TimeOut -> Systemd.Container
+autoBuilderContainer suite arch flavor crontime timeout =
+	Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props
+		& osDebian suite arch
 		& autobuilder arch crontime timeout
   where
 	name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
 
 type Flavor = Maybe String
 
-standardAutoBuilder :: System -> Flavor -> Property HasInfo
-standardAutoBuilder osver@(System _ arch) flavor =
+standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+standardAutoBuilder suite arch flavor =
 	propertyList "standard git-annex autobuilder" $ props
-		& os osver
+		& osDebian suite arch
 		& buildDepsApt
 		& Apt.stdSourcesList
 		& Apt.unattendedUpgrades
@@ -122,10 +124,10 @@ standardAutoBuilder osver@(System _ arch) flavor =
 		& User.accountFor (User builduser)
 		& tree arch flavor
 
-stackAutoBuilder :: System -> Flavor -> Property HasInfo
-stackAutoBuilder osver@(System _ arch) flavor =
+stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+stackAutoBuilder suite arch flavor =
 	propertyList "git-annex autobuilder using stack" $ props
-		& os osver
+		& osDebian suite arch
 		& buildDepsNoHaskellLibs
 		& Apt.stdSourcesList
 		& Apt.unattendedUpgrades
@@ -134,34 +136,34 @@ stackAutoBuilder osver@(System _ arch) flavor =
 		& tree arch flavor
 		& stackInstalled
 
-stackInstalled :: Property NoInfo
-stackInstalled = withOS "stack installed" $ \o ->
+stackInstalled :: Property Linux
+stackInstalled = withOS "stack installed" $ \w o ->
 	case o of
 		(Just (System (Debian (Stable "jessie")) "i386")) ->
-			ensureProperty $ manualinstall "i386"
-		_ -> ensureProperty $ Apt.installed ["haskell-stack"]
+			ensureProperty w $ manualinstall "i386"
+		_ -> ensureProperty w $ Apt.installed ["haskell-stack"]
   where
 	-- Warning: Using a binary downloaded w/o validation.
-	manualinstall arch = check (not <$> doesFileExist binstack) $
-		propertyList "stack installed from upstream tarball"
-			[ cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
+	manualinstall :: Architecture -> Property Linux
+	manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $
+		propertyList "stack installed from upstream tarball" $ props
+			& cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
 				`assume` MadeChange
-			, File.dirExists tmpdir
-			, cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
+			& File.dirExists tmpdir
+			& cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
 				`assume` MadeChange
-			, cmdProperty "mv" [tmpdir </> "stack", binstack]
+			& cmdProperty "mv" [tmpdir </> "stack", binstack]
 				`assume` MadeChange
-			, cmdProperty "rm" ["-rf", tmpdir, tmptar]
+			& cmdProperty "rm" ["-rf", tmpdir, tmptar]
 				`assume` MadeChange
-			]
 	binstack = "/usr/bin/stack"
 	tmptar = "/root/stack.tar.gz"
 	tmpdir = "/root/stack"
 
-armAutoBuilder :: System -> Flavor -> Property HasInfo
-armAutoBuilder osver flavor = 
+armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+armAutoBuilder suite arch flavor = 
 	propertyList "arm git-annex autobuilder" $ props
-		& standardAutoBuilder osver flavor
+		& standardAutoBuilder suite arch flavor
 		& buildDepsNoHaskellLibs
 		-- Works around ghc crash with parallel builds on arm.
 		& (homedir </> ".cabal" </> "config")
@@ -172,26 +174,30 @@ armAutoBuilder osver flavor =
 
 androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
 androidAutoBuilderContainer crontimes timeout =
-	androidContainer "android-git-annex-builder" (tree "android" Nothing) builddir
-		& Apt.unattendedUpgrades
-		& buildDepsNoHaskellLibs
-		& autobuilder "android" crontimes timeout
+	androidAutoBuilderContainer' "android-git-annex-builder"
+		(tree "android" Nothing) builddir crontimes timeout
 
 -- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer
-	:: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
-	=> Systemd.MachineName
-	-> Property i
+androidAutoBuilderContainer'
+	:: Systemd.MachineName
+	-> Property DebianLike
 	-> FilePath
+	-> Times
+	-> TimeOut
 	-> Systemd.Container
-androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap
-	& Apt.stdSourcesList
-	& User.accountFor (User builduser)
-	& File.dirExists gitbuilderdir
-	& File.ownerGroup homedir (User builduser) (Group builduser)
-	& flagFile chrootsetup ("/chrootsetup")
-		`requires` setupgitannexdir
-	& haskellPkgsInstalled "android"
+androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout = 
+	Systemd.container name $ \d -> bootstrap d $ props
+		& osDebian (Stable "jessie") "i386"
+		& Apt.stdSourcesList
+		& User.accountFor (User builduser)
+		& File.dirExists gitbuilderdir
+		& File.ownerGroup homedir (User builduser) (Group builduser)
+		& flagFile chrootsetup ("/chrootsetup")
+			`requires` setupgitannexdir
+		& haskellPkgsInstalled "android"
+		& Apt.unattendedUpgrades
+		& buildDepsNoHaskellLibs
+		& autobuilder "android" crontimes timeout
   where
 	-- Use git-annex's android chroot setup script, which will install
 	-- ghc-android and the NDK, all build deps, etc, in the home
@@ -200,5 +206,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name osve
 		[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
 		]
 		`assume` MadeChange
-	osver = System (Debian (Stable "jessie")) "i386"
 	bootstrap = Chroot.debootstrapped mempty
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index eaf7df8b..94215593 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -188,19 +188,18 @@ machined = withOS "machined installed" $ \w o ->
 -- add a property such as `osDebian` to specify the operating system
 -- to bootstrap.
 --
--- > container "webserver" (Chroot.debootstrapped mempty)
+-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props
 -- >	& osDebian Unstable "amd64"
 -- >    & Apt.installedRunning "apache2"
 -- >    & ...
 container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
 container name mkchroot = 
-	let c = Container name chroot h
+	let c = Container name chroot (host name (containerProps chroot))
 	in setContainerProps c $ containerProps c
 		&^ resolvConfed
 		&^ linkJournal
   where
 	chroot = mkchroot (containerDir name)
-	h = Host name [] mempty
 
 -- | Runs a container using systemd-nspawn.
 --
-- 
cgit v1.3-2-g0d8e


From 500635568514bc106597a857c60d268dcf668037 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 27 Mar 2016 18:32:01 -0400
Subject: split out singletons lib

---
 debian/changelog                  |  4 ++--
 propellor.cabal                   |  1 +
 src/Propellor/Types/MetaTypes.hs  | 14 +-------------
 src/Propellor/Types/Singletons.hs | 17 +++++++++++++++++
 4 files changed, 21 insertions(+), 15 deletions(-)
 create mode 100644 src/Propellor/Types/Singletons.hs

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index fc499c86..af2f5c2b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -39,10 +39,10 @@ propellor (3.0.0) UNRELEASED; urgency=medium
 		go = property "foo" (return NoChange)
       To fix, specify the type of go:
 	  	go :: Property UnixLike
-    - `ensureProperty` now needs to be passed information about the
+    - `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 $ \o -> ... ensureProperty o 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.
diff --git a/propellor.cabal b/propellor.cabal
index 4a7739d3..f11d2afe 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -162,6 +162,7 @@ Library
     Propellor.Types.PrivData
     Propellor.Types.Result
     Propellor.Types.ResultCheck
+    Propellor.Types.Singletons
     Propellor.Types.ZFS
   Other-Modules:
     Propellor.Bootstrap
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index 3e89e28d..39d6e725 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -25,6 +25,7 @@ module Propellor.Types.MetaTypes (
 	EqT,
 ) where
 
+import Propellor.Types.Singletons
 import Propellor.Types.OS
 
 data MetaType
@@ -49,13 +50,6 @@ type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l
 
 type MetaTypes = Sing
 
--- | The data family of singleton types.
-data family Sing (x :: k)
-
--- | A class used to pass singleton values implicitly.
-class SingI t where
-	sing :: Sing t
-
 -- This boilerplatw would not be needed if the singletons library were
 -- used. However, we're targeting too old a version of ghc to use it yet.
 data instance Sing (x :: MetaType) where
@@ -68,12 +62,6 @@ instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS
 instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS
 instance SingI 'WithInfo where sing = WithInfoS
 
-data instance Sing (x :: [k]) where
-	Nil :: Sing '[]
-	Cons :: Sing x -> Sing xs -> Sing (x ': xs)
-instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing
-instance SingI '[] where sing = Nil
-
 -- | Convenience type operator to combine two `MetaTypes` lists.
 --
 -- For example:
diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs
new file mode 100644
index 00000000..be777ecb
--- /dev/null
+++ b/src/Propellor/Types/Singletons.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs #-}
+
+module Propellor.Types.Singletons where
+
+-- | The data family of singleton types.
+data family Sing (x :: k)
+
+-- | A class used to pass singleton values implicitly.
+class SingI t where
+	sing :: Sing t
+
+-- Lists of singletons
+data instance Sing (x :: [k]) where
+	Nil :: Sing '[]
+	Cons :: Sing x -> Sing xs -> Sing (x ': xs)
+instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing
+instance SingI '[] where sing = Nil
-- 
cgit v1.3-2-g0d8e


From af7b2d61c0c7f9b4fe53d8f5d18b5426a93cbd7b Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
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 'debian')

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 <id@joeyh.name>  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 <id@joeyh.name>
 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 <id@joeyh.name>
--- 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 <id@joeyh.name>
--- 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 <id@joeyh.name>
--- 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 d725caa03420d5f3b9ffe6124de39ab00979f7cb Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 28 Mar 2016 03:52:30 -0400
Subject: backports are debian only

---
 debian/changelog              | 2 +-
 src/Propellor/Property/Apt.hs | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index 036b8f34..e4fbd15e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -56,7 +56,7 @@ propellor (3.0.0) UNRELEASED; urgency=medium
       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.
+    which to use based on the Host's OS.
   * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling
     these complex new types.
   * Added dependency on concurrent-output; removed embedded copy.
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index c8ad92e4..2199d950 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -157,7 +157,7 @@ installed' params ps = robustly $ check (isInstallable ps) go
   where
 	go = runApt (params ++ ["install"] ++ ps)
 
-installedBackport :: [Package] -> Property DebianLike
+installedBackport :: [Package] -> Property Debian
 installedBackport ps = withOS desc $ \w o -> case o of
 	(Just (System (Debian suite) _)) -> case backportSuite suite of
 		Nothing -> unsupportedOS
-- 
cgit v1.3-2-g0d8e


From 0f410f8acdb9e0b84ae364e80e5ee63adcb2ee50 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 30 Mar 2016 15:18:39 -0400
Subject: When new dependencies are added to propellor or the propellor config,
 try harder to get them installed.

In particular, this makes  propellor --spin work when the remote host needs
to get dependencies installed in order to build the updated config.

Fixes http://propellor.branchable.com/todo/problem_with_spin_after_new_dependencies_added/
---
 debian/changelog           |  4 ++++
 src/Propellor/Bootstrap.hs | 33 ++++++++++++++++++++++++---------
 src/Propellor/CmdLine.hs   | 30 +++++++++++++++---------------
 src/wrapper.hs             |  2 +-
 4 files changed, 44 insertions(+), 25 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index 1075773d..abc7d530 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -60,6 +60,10 @@ propellor (3.0.0) UNRELEASED; urgency=medium
   * 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.
+  * When new dependencies are added to propellor or the propellor config,
+    try harder to get them installed. In particular, this makes 
+    propellor --spin work when the remote host needs to get dependencies
+    installed in order to build the updated config.
 
  -- Joey Hess <id@joeyh.name>  Thu, 24 Mar 2016 15:02:33 -0400
 
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 2ad0f688..b60dd8c4 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -6,6 +6,7 @@ module Propellor.Bootstrap (
 ) where
 
 import Propellor.Base
+import Propellor.Types.Info
 
 import System.Posix.Files
 import Data.List
@@ -130,22 +131,27 @@ installGitCommand msys = case msys of
 		, "DEBIAN_FRONTEND=noninteractive apt-get --no-install-recommends --no-upgrade -y install git"
 		]
 
-buildPropellor :: IO ()
-buildPropellor = unlessM (actionMessage "Propellor build" build) $
+buildPropellor :: Maybe Host -> IO ()
+buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $
 	errorMessage "Propellor build failed!"
+  where
+	msys = case fmap (fromInfo . hostInfo) mh of
+		Just (InfoVal sys) -> Just sys
+		_ -> Nothing
 
 -- Build propellor using cabal, and symlink propellor to where cabal
 -- leaves the built binary.
 --
 -- 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.
-build :: IO Bool
-build = catchBoolIO $ do
-	make "dist/setup-config" ["propellor.cabal"] $
-		cabal ["configure"]
-	unlessM (cabal ["build", "propellor-config"]) $ do
-		void $ cabal ["configure"]
-		unlessM (cabal ["build"]) $
+--
+-- If the cabal configure fails, and a System is provided, installs
+-- dependencies and retries.
+build :: Maybe System -> IO Bool
+build msys = catchBoolIO $ do
+	make "dist/setup-config" ["propellor.cabal"] cabal_configure
+	unlessM cabal_build $
+		unlessM (cabal_configure <&&> cabal_build) $
 			error "cabal build failed"
 	-- For safety against eg power loss in the middle of the build,
 	-- make a copy of the binary, and move it into place atomically.
@@ -165,6 +171,15 @@ build = catchBoolIO $ do
 	cabalbuiltbin = "dist/build/propellor-config/propellor-config"
 	safetycopy = cabalbuiltbin ++ ".built"
 	tmpfor f = f ++ ".propellortmp"
+	cabal_configure = ifM (cabal ["configure"])
+		( return True
+		, case msys of
+			Nothing -> return False
+			Just sys -> 
+				boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))]
+					<&&> cabal ["configure"]
+		)
+	cabal_build = cabal ["build", "propellor-config"]
 
 make :: FilePath -> [FilePath] -> IO Bool -> IO ()
 make dest srcs builder = do
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index ee057d05..8fd2bf18 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -114,20 +114,20 @@ defaultMain hostlist = withConcurrentOutput $ do
 	go _ (DockerInit hn) = Docker.init hn
 	go _ (GitPush fin fout) = gitPushHelper fin fout
 	go cr (Relay h) = forceConsole >>
-		updateFirst cr (Update (Just h)) (update (Just h))
+		updateFirst Nothing cr (Update (Just h)) (update (Just h))
 	go _ (Update Nothing) = forceConsole >>
 		fetchFirst (onlyprocess (update Nothing))
 	go _ (Update (Just h)) = update (Just h)
 	go _ Merge = mergeSpin
-	go cr cmdline@(Spin hs mrelay) = buildFirst cr cmdline $ do
+	go cr cmdline@(Spin hs mrelay) = buildFirst Nothing cr cmdline $ do
 		unless (isJust mrelay) commitSpin
 		forM_ hs $ \hn -> withhost hn $ spin mrelay hn
 	go cr cmdline@(Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( updateFirst cr cmdline $ runhost hn
+		( updateFirst (findHost hostlist hn) cr cmdline $ runhost hn
 		, fetchFirst $ go cr (Spin [hn] Nothing)
 		)
 	go cr cmdline@(SimpleRun hn) = forceConsole >>
-		fetchFirst (buildFirst cr cmdline (runhost hn))
+		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
 
@@ -149,17 +149,17 @@ unknownhost h hosts = errorMessage $ unlines
 -- Builds propellor (when allowed) and if it looks like a new binary,
 -- re-execs it to continue.
 -- Otherwise, runs the IO action to continue.
-buildFirst :: CanRebuild -> CmdLine -> IO () -> IO ()
-buildFirst CanRebuild cmdline next = do
+buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
+buildFirst h CanRebuild cmdline next = do
 	oldtime <- getmtime
-	buildPropellor
+	buildPropellor h
 	newtime <- getmtime
 	if newtime == oldtime
 		then next
 		else continueAfterBuild cmdline
   where
 	getmtime = catchMaybeIO $ getModificationTime "propellor"
-buildFirst NoRebuild _ next = next
+buildFirst _ NoRebuild _ next = next
 
 continueAfterBuild :: CmdLine -> IO a
 continueAfterBuild cmdline = go =<< boolSystem "./propellor"
@@ -176,23 +176,23 @@ fetchFirst next = do
 		void fetchOrigin
 	next
 
-updateFirst :: CanRebuild -> CmdLine -> IO () -> IO ()
-updateFirst canrebuild cmdline next = ifM hasOrigin
-	( updateFirst' canrebuild cmdline next
+updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
+updateFirst h canrebuild cmdline next = ifM hasOrigin
+	( updateFirst' h canrebuild cmdline next
 	, next
 	)
 
 -- If changes can be fetched from origin,  Builds propellor (when allowed)
 -- and re-execs the updated propellor binary to continue.
 -- Otherwise, runs the IO action to continue.
-updateFirst' :: CanRebuild -> CmdLine -> IO () -> IO ()
-updateFirst' CanRebuild cmdline next = ifM fetchOrigin
+updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
+updateFirst' h CanRebuild cmdline next = ifM fetchOrigin
 	( do
-		buildPropellor
+		buildPropellor h
 		continueAfterBuild cmdline
 	, next
 	)
-updateFirst' NoRebuild _ next = next
+updateFirst' _ NoRebuild _ next = next
 
 -- Gets the fully qualified domain name, given a string that might be
 -- a short name to look up in the DNS.
diff --git a/src/wrapper.hs b/src/wrapper.hs
index a204b60c..289b12b5 100644
--- a/src/wrapper.hs
+++ b/src/wrapper.hs
@@ -99,7 +99,7 @@ wrapper args propellordir propellorbin = do
 					warnoutofdate propellordir True
 	buildruncfg = do
 		changeWorkingDirectory propellordir
-		buildPropellor
+		buildPropellor Nothing
 		putStrLn ""
 		putStrLn ""
 		chain
-- 
cgit v1.3-2-g0d8e


From 1755835c5cae7e0771512b137dd06fb29a8b940b Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 30 Mar 2016 16:35:45 -0400
Subject: Apt.PPA: New module, contributed by Evan Cofsky.

Merged https://github.com/joeyh/propellor/pull/15
---
 debian/changelog | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index e31c8d51..ee3311e4 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -63,6 +63,9 @@ propellor (3.0.0) UNRELEASED; urgency=medium
   * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling
     these complex new types.
   * Added dependency on concurrent-output; removed embedded copy.
+  * Apt.PPA: New module, contributed by Evan Cofsky.
+
+ -- Joey Hess <id@joeyh.name>  Wed, 30 Mar 2016 15:45:08 -0400
 
 propellor (2.17.2) unstable; urgency=medium
 
-- 
cgit v1.3-2-g0d8e


From 503437b676f5c4d41ef41c6de3e3b25045bcc5d7 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 1 Apr 2016 18:33:17 -0400
Subject: 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.

---
 debian/changelog |   3 +
 src/wrapper.hs   | 254 +++++++++++++++++++++++++++++++++++++++++--------------
 2 files changed, 193 insertions(+), 64 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index ee3311e4..14d3f1a9 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -64,6 +64,9 @@ 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
+    a clone of propellor's git repository, or a minimal config.
 
  -- Joey Hess <id@joeyh.name>  Wed, 30 Mar 2016 15:45:08 -0400
 
diff --git a/src/wrapper.hs b/src/wrapper.hs
index 289b12b5..f079eb32 100644
--- a/src/wrapper.hs
+++ b/src/wrapper.hs
@@ -5,12 +5,8 @@
 --
 -- This is not the propellor main program (that's config.hs)
 --
--- This installs propellor's source into ~/.propellor,
--- uses it to build the real propellor program (if not already built),
--- and runs it.
--- 
--- The source is cloned from /usr/src/propellor when available,
--- or is cloned from git over the network.
+-- This bootstraps ~/.propellor/config.hs, builds it if
+-- it's not already built, and runs it.
 
 module Main where
 
@@ -22,6 +18,7 @@ import Utility.Process
 import Utility.SafeCommand
 import Utility.Exception
 
+import Data.Char
 import Control.Monad
 import Control.Monad.IfElse
 import System.Directory
@@ -36,9 +33,12 @@ 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"
 
@@ -54,60 +54,186 @@ main :: IO ()
 main = withConcurrentOutput $ do
 	args <- getArgs
 	home <- myHomeDir
-	let propellordir = home </> ".propellor"
-	let propellorbin = propellordir </> "propellor"
-	wrapper args propellordir propellorbin
-
-wrapper :: [String] -> FilePath -> FilePath -> IO ()
-wrapper args propellordir propellorbin = do
-	ifM (doesDirectoryExist propellordir)
-		( checkRepo 
-		, makeRepo
+	let dotpropellor = home </> ".propellor"
+	ifM (doesDirectoryExist dotpropellor)
+		( do
+			checkRepoUpToDate dotpropellor
+			buildRunConfig dotpropellor args
+		, do
+			welcomeBanner
+			setup dotpropellor
 		)
-	buildruncfg
+
+buildRunConfig :: FilePath -> [String] -> IO ()
+buildRunConfig dotpropellor args = do
+	changeWorkingDirectory dotpropellor
+	buildPropellor Nothing
+	putStrLn ""
+	putStrLn ""
+	chain
   where
-	makeRepo = do
-		putStrLn $ "Setting up your propellor repo in " ++ propellordir
-		putStrLn ""
-		ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo)
-			( do			
-				void $ boolSystem "git" [Param "clone", File distrepo, File propellordir]
-				fetchUpstreamBranch propellordir distrepo
-				changeWorkingDirectory propellordir
-				void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]
-			, do
-				void $ boolSystem "git" [Param "clone", Param netrepo, File propellordir]
-				changeWorkingDirectory propellordir
-				-- 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"]
-			)
-
-	checkRepo = whenM (doesFileExist disthead <&&> doesFileExist (propellordir </> "propellor.cabal")) $ do
-		headrev <- takeWhile (/= '\n') <$> readFile disthead
-		changeWorkingDirectory propellordir
-		headknown <- catchMaybeIO $ 
-			withQuietOutput createProcessSuccess $
-				proc "git" ["log", headrev]
-		if (headknown == Nothing)
-			then setupupstreammaster headrev propellordir
-			else do
-				merged <- not . null <$>
-					readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"]
-				unless merged $
-					warnoutofdate propellordir True
-	buildruncfg = do
-		changeWorkingDirectory propellordir
-		buildPropellor Nothing
-		putStrLn ""
-		putStrLn ""
-		chain
+	propellorbin = dotpropellor </> "propellor"
 	chain = do
 		(_, _, _, pid) <- createProcess (proc propellorbin args) 
 		exitWith =<< waitForProcess pid
 
--- Passed the user's propellordir repository, makes upstream/master
+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 -> [(Char, IO ())] -> IO ()
+prompt p cs = do
+	putStr (p ++ " [" ++ map fst cs ++ "] ")
+	hFlush stdout
+	r <- map toLower <$> getLine
+	if r == "\n"
+		then snd (head cs) -- default to first choice on return
+		else case filter (\(c, a) -> [toLower c] == 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!"
+	
+	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."
+
+	section
+	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!"
+
+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
+			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,
@@ -122,12 +248,12 @@ wrapper args propellordir propellorbin = do
 -- 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 propellordir = do
-	changeWorkingDirectory propellordir
+setupUpstreamMaster :: String -> FilePath -> IO ()
+setupUpstreamMaster newref dotpropellor = do
+	changeWorkingDirectory dotpropellor
 	go =<< catchMaybeIO getoldrev
   where
-	go Nothing = warnoutofdate propellordir False
+	go Nothing = warnoutofdate dotpropellor False
 	go (Just oldref) = do
 		let tmprepo = ".git/propellordisttmp"
 		let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo
@@ -139,9 +265,9 @@ setupupstreammaster newref propellordir = do
 		git ["reset", "--hard", oldref, "--quiet"]
 		git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"]
 	
-		fetchUpstreamBranch propellordir tmprepo
+		fetchUpstreamBranch dotpropellor tmprepo
 		cleantmprepo
-		warnoutofdate propellordir True
+		warnoutofdate dotpropellor True
 
 	getoldrev = takeWhile (/= '\n')
 		<$> readProcess "git" ["show-ref", upstreambranch, "--hash"]
@@ -151,8 +277,8 @@ setupupstreammaster newref propellordir = do
 		error $ "Failed to run " ++ cmd ++ " " ++ show ps
 
 warnoutofdate :: FilePath -> Bool -> IO ()
-warnoutofdate propellordir havebranch = do
-	warningMessage ("** Your " ++ propellordir ++ " is out of date..")
+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
@@ -161,8 +287,8 @@ warnoutofdate propellordir havebranch = do
 	also ""
 
 fetchUpstreamBranch :: FilePath -> FilePath -> IO ()
-fetchUpstreamBranch propellordir repo = do
-	changeWorkingDirectory propellordir
+fetchUpstreamBranch dotpropellor repo = do
+	changeWorkingDirectory dotpropellor
 	void $ boolSystem "git"
 		[ Param "fetch"
 		, File repo
-- 
cgit v1.3-2-g0d8e


From 93b083f3a1204a7cf4452b5ebd589dd77d25dbac Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
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 'debian')

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 <id@joeyh.name>  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 <joeyh@joeyh.name>
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 'debian')

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 <joeyh@joeyh.name>
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 'debian')

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 <id@joeyh.name>  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


From 48608a48bd91743776cf3d4abb2172b806d4b917 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 2 Apr 2016 15:33:37 -0400
Subject: prep release

---
 debian/changelog | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'debian')

diff --git a/debian/changelog b/debian/changelog
index aab077b0..4c432a73 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,4 +1,4 @@
-propellor (3.0.0) UNRELEASED; urgency=medium
+propellor (3.0.0) unstable; urgency=medium
 
   * Property types have been improved to indicate what systems they target.
     This prevents using eg, Property FreeBSD on a Debian system.
@@ -73,7 +73,7 @@ propellor (3.0.0) UNRELEASED; urgency=medium
   * When propellor is installed using stack, propellor --init will
     automatically set propellor.buildsystem=stack.
 
- -- Joey Hess <id@joeyh.name>  Wed, 30 Mar 2016 15:45:08 -0400
+ -- Joey Hess <id@joeyh.name>  Sat, 02 Apr 2016 15:33:26 -0400
 
 propellor (2.17.2) unstable; urgency=medium
 
-- 
cgit v1.3-2-g0d8e