From 6d52245a574e65275f818d90839737f0074b045f Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 8 Mar 2016 15:08:58 -0400
Subject: document status

---
 ...ent_2_5a1c0c54db25b039eda28e213e1e6263._comment | 43 ++++++++++++++++++++++
 1 file changed, 43 insertions(+)
 create mode 100644 doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment

(limited to 'doc/todo')

diff --git a/doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment b/doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment
new file mode 100644
index 00000000..27aaf0cd
--- /dev/null
+++ b/doc/todo/type_level_OS_requirements/comment_2_5a1c0c54db25b039eda28e213e1e6263._comment
@@ -0,0 +1,43 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 2"""
+ date="2016-03-08T18:44:25Z"
+ content="""
+I've made a typed-os-requirements branch that has type-level
+OS lists implemented.
+
+For example:
+
+	*Propellor.Types.OS.TypeLevel> let l = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike
+	*Propellor.Types.OS.TypeLevel> l
+	OSList [OSDebian,OSFreeBSD]
+	*Propellor.Types.OS.TypeLevel> :t l
+	l :: OSList
+	       (IntersectOSList
+	          '[] '['OSDebian, 'OSFreeBSD] '['OSDebian, 'OSBuntish, 'OSFreeBSD])
+
+What this is lacking is type-level equality for OSList.
+The complicated type above should be equivilant to `OSList '[OSDebian, OSFreeBSD]`
+
+So, this doesn't type check yet:
+
+	foo :: OSList '[OSDebian, OSFreeBSD]
+	foo = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike 
+
+	src/Propellor/Types/OS/Typelevel.hs:47:46:
+	    Couldn't match expected type ‘IntersectOSList
+	                                    '[]
+	                                    '['OSDebian, 'OSFreeBSD]
+	                                    '['OSDebian, 'OSBuntish, 'OSFreeBSD]’
+	                with actual type ‘'['OSDebian, 'OSFreeBSD]’
+	    In the expression:
+	      (debian `combineSupportedOS` freeBSD)
+	      `intersectSupportedOS` unixlike
+	    In an equation for ‘foo’:
+	        foo
+	          = (debian `combineSupportedOS` freeBSD)
+	            `intersectSupportedOS` unixlike
+
+Also, `intersectSupportedOS` should have an additional constraint,
+to prevent it from generating an empty type-level list.
+"""]]
-- 
cgit v1.3-2-g0d8e


From 61a1ba8ff1fa496af24d22986057a7607ae55ff1 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 8 Mar 2016 17:54:49 -0400
Subject: make it a type error to intersect two OS lists if the result is empty

---
 doc/todo/type_level_OS_requirements.mdwn |  4 +++-
 src/Propellor/Types/OS/Typelevel.hs      | 15 +++++++++++----
 2 files changed, 14 insertions(+), 5 deletions(-)

(limited to 'doc/todo')

diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn
index 65e6099f..6d5d7aaf 100644
--- a/doc/todo/type_level_OS_requirements.mdwn
+++ b/doc/todo/type_level_OS_requirements.mdwn
@@ -11,7 +11,9 @@ For example, `Property i '[Debian, FreeBSD]` combined with `Property i '[Debian,
 yields a `Property i '[Debian]` -- the intersection of the OS's supported by
 the combined properties.
 
-And, combining two properties that demand different OS's would need to be a
+Combining two properties that demand different OS's would yield a
+`Property i '[]` -- since the type level OS list is empty,
+
 type error. Can a type level function combine two types successfully, and
 fail to combine two others somehow? Don't know. Maybe combine to an
 IncoherentOS and don't allow a `Property i IncoherentOS` to be used in a
diff --git a/src/Propellor/Types/OS/Typelevel.hs b/src/Propellor/Types/OS/Typelevel.hs
index 82f3a426..879259df 100644
--- a/src/Propellor/Types/OS/Typelevel.hs
+++ b/src/Propellor/Types/OS/Typelevel.hs
@@ -43,9 +43,8 @@ freeBSD = typeOS OSFreeBSD
 typeOS :: SupportedOS -> OSList os
 typeOS o = OSList [o]
 
--- FIXME, should type check
--- foo :: OSList '[OSDebian, OSFreeBSD]
--- foo = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike 
+foo :: OSList '[OSDebian, OSFreeBSD]
+foo = (debian `combineSupportedOS` freeBSD ) `intersectSupportedOS` unixlike 
 
 -- | Combines two lists of supported OS's, yielding a list with the
 -- contents of both.
@@ -63,12 +62,20 @@ type instance ConcatOSList (a ': rest) list2 = a ': ConcatOSList rest list2
 
 -- | The intersection between two lists of supported OS's.
 intersectSupportedOS
-	:: (r ~ IntersectOSList l1 l2)
+	:: (r ~ IntersectOSList l1 l2, CannotCombineOS l1 l2 r ~ CanCombineOS)
 	=> OSList l1
 	-> OSList l2
 	-> OSList r
 intersectSupportedOS (OSList l1) (OSList l2) = OSList (filter (`elem` l2) l1)
 
+-- | Detect intersection of two lists that don't have any common OS.
+-- 
+-- The name of this was chosen to make type errors a more understandable.
+type family CannotCombineOS (list1 :: [a]) (list2 :: [a]) (listr :: [a]) :: CheckIntersection
+type instance CannotCombineOS l1 l2 '[] = 'CannotCombineOS
+type instance CannotCombineOS l1 l2 (a ': rest) = 'CanCombineOS
+data CheckIntersection = CannotCombineOS | CanCombineOS
+
 -- | Type level intersection for OSList
 type family IntersectOSList (list1 :: [a]) (list2 :: [a]) :: [a]
 type instance IntersectOSList '[] list2 = '[]
-- 
cgit v1.3-2-g0d8e


From 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 'doc/todo')

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 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 'doc/todo')

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 ebdbac3243d7881e2bfac1ff293cf04c7cd69c91 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 28 Mar 2016 09:31:57 -0400
Subject: add

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

(limited to 'doc/todo')

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


From cebf755a6710548bcff4474e6010eefb83db08ac Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 28 Mar 2016 11:06:23 -0400
Subject: close

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

(limited to 'doc/todo')

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


From 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 'doc/todo')

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 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 'doc/todo')

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