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.
---
 src/Propellor/Property/Chroot.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/Propellor/Property/Chroot.hs')

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)
 
-- 
cgit v1.3-2-g0d8e


From f01776d64b1b8fcf89903d0de1ffe27f10d620ee Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 25 Mar 2016 16:20:32 -0400
Subject: rename toProp to toChildProperties

and note that it's not meant to be used by regular users
---
 config-simple.hs                 | 12 ------------
 src/Propellor/Engine.hs          |  2 +-
 src/Propellor/PropAccum.hs       |  6 +++---
 src/Propellor/Property/Chroot.hs |  7 +++----
 src/Propellor/Property/Docker.hs |  4 +---
 src/Propellor/Property/List.hs   |  6 +++---
 src/Propellor/Types.hs           | 23 ++++++-----------------
 7 files changed, 17 insertions(+), 43 deletions(-)

(limited to 'src/Propellor/Property/Chroot.hs')

diff --git a/config-simple.hs b/config-simple.hs
index 28b38409..da1580c6 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -12,7 +12,6 @@ import Propellor.Property.Scheduled
 import qualified Propellor.Property.User as User
 --import qualified Propellor.Property.Hostname as Hostname
 --import qualified Propellor.Property.Tor as Tor
-import qualified Propellor.Property.Docker as Docker
 
 main :: IO ()
 main = defaultMain hosts
@@ -34,15 +33,4 @@ mybox = host "mybox.example.com" $ props
 	& User.hasSomePassword (User "root")
 	& Network.ipv6to4
 	& File.dirExists "/var/www"
-	& Docker.docked webserverContainer
-	& Docker.garbageCollected `period` Daily
 	& Cron.runPropellor (Cron.Times "30 * * * *")
-
--- A generic webserver in a Docker container.
-webserverContainer :: Docker.Container
-webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props
-	& os (System (Debian (Stable "jessie")) "amd64")
-	& Apt.stdSourcesList
-	& Docker.publish "80:80"
-	& Docker.volume "/var/www:/var/www"
-	& Apt.serviceInstalledRunning "apache2"
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index bf49b95f..4c37e704 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -33,7 +33,7 @@ import Utility.Exception
 -- with nice display of what's being done.
 mainProperties :: Host -> IO ()
 mainProperties host = do
-	ret <- runPropellor host $ ensureChildProperties [toProp overall]
+	ret <- runPropellor host $ ensureChildProperties [toChildProperty overall]
 	messagesDone
 	case ret of
 		FailedChange -> exitWith (ExitFailure 1)
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 06b8ad3f..7547a81d 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -62,7 +62,7 @@ type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t
 	=> Props (MetaTypes x)
 	-> p
 	-> Props (MetaTypes (Combine x y))
-Props c & p = Props (c ++ [toProp p])
+Props c & p = Props (c ++ [toChildProperty p])
 
 -- | Adds a property before any other properties.
 (&^)
@@ -74,7 +74,7 @@ Props c & p = Props (c ++ [toProp p])
 	=> Props (MetaTypes x)
 	-> p
 	-> Props (MetaTypes (Combine x y))
-Props c &^ p = Props (toProp p : c)
+Props c &^ p = Props (toChildProperty p : c)
 
 -- | Adds a property in reverted form.
 (!)
@@ -82,7 +82,7 @@ Props c &^ p = Props (toProp p : c)
 	=> Props (MetaTypes x)
 	-> RevertableProperty (MetaTypes y) (MetaTypes z)
 	-> Props (MetaTypes (Combine x z))
-Props c ! p = Props (c ++ [toProp (revert p)])
+Props c ! p = Props (c ++ [toChildProperty (revert p)])
 
 {-
 
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index fb05d659..bf6f2083 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -213,11 +213,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
 		changeWorkingDirectory localdir
 		when onconsole forceConsole
 		onlyProcess (provisioningLock loc) $ do
-			r <- runPropellor (setInChroot h) $ ensureProperties $
+			r <- runPropellor (setInChroot h) $ ensureChildProperties $
 				if systemdonly
-					then [Systemd.installed]
-					else map ignoreInfo $
-						hostProperties h
+					then [toProp Systemd.installed]
+					else hostProperties h
 			flushConcurrentOutput
 			putStrLn $ "\n" ++ show r
 chain _ _ = errorMessage "bad chain command"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 4bbfeef3..d19d15aa 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -581,9 +581,7 @@ chain hostlist hn s = case toContainerId s of
 	go cid h = do
 		changeWorkingDirectory localdir
 		onlyProcess (provisioningLock cid) $ do
-			r <- runPropellor h $ ensureChildProperties $
-				map ignoreInfo $
-					hostProperties h
+			r <- runPropellor h $ ensureChildProperties $ hostProperties h
 			flushConcurrentOutput
 			putStrLn $ "\n" ++ show r
 
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 44916f23..d8c5cff4 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -21,7 +21,7 @@ import Propellor.Exception
 import Data.Monoid
 
 toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
-toProps ps = Props (map toProp ps)
+toProps ps = Props (map toChildProperty ps)
 
 -- | Combines a list of properties, resulting in a single property
 -- that when run will run each property in the list in turn,
@@ -38,7 +38,7 @@ propertyList desc (Props ps) =
 	property desc (ensureChildProperties cs)
 		`modifyChildren` (++ cs)
   where
-	cs = map toProp ps
+	cs = map toChildProperty ps
 
 -- | Combines a list of properties, resulting in one property that
 -- ensures each in turn. Stops if a property fails.
@@ -47,7 +47,7 @@ combineProperties desc (Props ps) =
 	property desc (combineSatisfy cs NoChange)
 		`modifyChildren` (++ cs)
   where
-	cs = map toProp ps
+	cs = map toChildProperty ps
 
 combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
 combineSatisfy [] rs = return rs
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index dd8721ac..f42f55d7 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -158,18 +158,6 @@ addInfoProperty
 addInfoProperty (Property _ d a oldi c) newi =
 	Property sing d a (oldi <> newi) c
 
-{-
-
--- | Makes a version of a Proprty without its Info.
--- Use with caution!
-ignoreInfo
-	:: (metatypes' ~ 
-	=> Property metatypes
-	-> Property (MetaTypes metatypes')
-ignoreInfo = 
-
--}
-
 -- | 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
@@ -213,7 +201,9 @@ class IsProp p where
 	-- | Gets the info of the property, combined with all info
 	-- of all children properties.
 	getInfoRecursive :: p -> Info
-	toProp :: p -> ChildProperty
+	-- | Gets a ChildProperty representing the Property.
+	-- You should not normally need to use this.
+	toChildProperty :: 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.
@@ -225,7 +215,7 @@ instance IsProp (Property metatypes) where
 	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
+	toChildProperty (Property _ d a i c) = ChildProperty d a i c
 	getSatisfy (Property _ _ a _ _) = a
 
 instance IsProp ChildProperty where
@@ -234,7 +224,7 @@ instance IsProp ChildProperty where
 	modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c)
 	getInfoRecursive (ChildProperty _ _ i c) =
 		i <> mconcat (map getInfoRecursive c)
-	toProp = id
+	toChildProperty = id
 	getSatisfy (ChildProperty _ a _ _) = a
 
 instance IsProp (RevertableProperty setupmetatypes undometatypes) where
@@ -243,10 +233,9 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where
 		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
+	toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1
 	getSatisfy (RevertableProperty p1 _) = getSatisfy p1
 
 -- | Type level calculation of the type that results from combining two
-- 
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 'src/Propellor/Property/Chroot.hs')

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 'src/Propellor/Property/Chroot.hs')

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 530b0dde35e143df1ba8cb8f4828e0a3bc0b4ffb Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 26 Mar 2016 19:49:03 -0400
Subject: ported Chroot!!

It ended up specialized to Linux for a few reasons, including
inChrootProcess's use of umountLazy which is linux specific.

The ChrootBootstrapper type class is specialized to Linux for no good
reason. Future work: Support other unix's.
---
 src/Propellor/Property/Chroot.hs | 41 +++++++++++++++++++++++-----------------
 1 file changed, 24 insertions(+), 17 deletions(-)

(limited to 'src/Propellor/Property/Chroot.hs')

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 547e5c94..a0f3aca8 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -19,6 +19,7 @@ module Propellor.Property.Chroot (
 ) where
 
 import Propellor.Base
+import Propellor.Container
 import Propellor.Types.CmdLine
 import Propellor.Types.Chroot
 import Propellor.Types.Info
@@ -40,8 +41,12 @@ import System.Console.Concurrent
 data Chroot where
 	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
 
+instance Container Chroot where
+	containerProperties (Chroot _ _ h) = containerProperties h
+	containerInfo (Chroot _ _ h) = containerInfo h
+
 chrootSystem :: Chroot -> Maybe System
-chrootSystem (Chroot _ _ h) = fromInfoVal (fromInfo (hostInfo h))
+chrootSystem = fromInfoVal . fromInfo . containerInfo
 
 instance Show Chroot where
 	show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
@@ -52,7 +57,7 @@ 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 + UnixLike))
+	buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux)
 
 -- | Use this to bootstrap a chroot by extracting a tarball.
 --
@@ -63,7 +68,8 @@ class ChrootBootstrapper b where
 data ChrootTarball = ChrootTarball FilePath
 
 instance ChrootBootstrapper ChrootTarball where
-	buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
+	buildchroot (ChrootTarball tb) _ loc = Right $
+		tightenTargets $ extractTarball loc tb
 
 extractTarball :: FilePath -> FilePath -> Property UnixLike
 extractTarball target src = check (unpopulated target) $
@@ -116,15 +122,20 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h
 -- Reverting this property removes the chroot. Anything mounted inside it
 -- is first unmounted. Note that it does not ensure that any processes
 -- that might be running inside the chroot are stopped.
-provisioned :: Chroot -> RevertableProperty HasInfo
+provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
 provisioned c = provisioned' (propagateChrootInfo c) c False
 
-provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo
+provisioned'
+	:: (Property Linux -> Property (HasInfo + Linux))
+	-> Chroot
+	-> Bool
+	-> RevertableProperty (HasInfo + Linux) Linux
 provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
-	(propigator $ propertyList (chrootDesc c "exists") [setup])
+	(propigator $ setup `describe` chrootDesc c "exists")
 		<!>
-	(propertyList (chrootDesc c "removed") [teardown])
+	(teardown `describe` chrootDesc c "removed")
   where
+	setup :: Property Linux
 	setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
 		`requires` built
 
@@ -134,18 +145,14 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
 
 	cantbuild e = property (chrootDesc c "built") (error e)
 
+	teardown :: Property Linux
 	teardown = check (not <$> unpopulated loc) $
 		property ("removed " ++ loc) $
 			makeChange (removeChroot loc)
 
-propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property (HasInfo + UnixLike)
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
-  where
-	p' = infoProperty
-		(getDesc p)
-		(getSatisfy p)
-		(getInfo p <> chrootInfo c)
-		(propertyChildren p)
+propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
+	p `addInfoProperty` chrootInfo c
 
 chrootInfo :: Chroot -> Info
 chrootInfo (Chroot loc _ h) = mempty `addInfo`
@@ -253,11 +260,11 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
 -- that does not let any daemons be started by packages that use
 -- invoke-rc.d. Reverting the property removes the script.
 noServices :: RevertableProperty DebianLike DebianLike
-noServices = setup <!> teardown
+noServices = tightenTargets setup <!> tightenTargets teardown
   where
 	f = "/usr/sbin/policy-rc.d"
 	script = [ "#!/bin/sh", "exit 101" ]
-	setup = combineProperties "no services started"
+	setup = combineProperties "no services started" $ toProps
 		[ File.hasContent f script
 		, File.mode f (combineModes (readModes ++ executeModes))
 		]
-- 
cgit v1.3-2-g0d8e


From 46fc5467e633a9c1f149cb0cd7ee03af1e9e0aa1 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 26 Mar 2016 21:38:39 -0400
Subject: ported docker

Also, implemented modifyHostProps to add properties to an existing host.
Using it bypasses some type safety. Its use in docker is safe though.

But, in Conductor, the use of it was not really safe, because it was used
with a DebianLike property. Fixed that by making Ssh.installed
target all unix's, although it will fail on non-DebianLike ones.
---
 config-simple.hs                                   |   7 --
 src/Propellor/Container.hs                         |   6 +-
 src/Propellor/PropAccum.hs                         |  18 ++++
 src/Propellor/Property/Chroot.hs                   |   2 +-
 src/Propellor/Property/Conductor.hs                |  21 ++--
 src/Propellor/Property/DiskImage.hs                |  16 +--
 src/Propellor/Property/Docker.hs                   | 111 ++++++++++++---------
 .../Property/HostingProvider/CloudAtCost.hs        |  33 +++---
 src/Propellor/Property/Hostname.hs                 |  21 ++--
 src/Propellor/Property/Ssh.hs                      |   9 +-
 10 files changed, 137 insertions(+), 107 deletions(-)

(limited to 'src/Propellor/Property/Chroot.hs')

diff --git a/config-simple.hs b/config-simple.hs
index 277e2edd..42b3d838 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -4,14 +4,8 @@
 import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Network as Network
---import qualified Propellor.Property.Ssh as Ssh
 import qualified Propellor.Property.Cron as Cron
-import Propellor.Property.Scheduled
---import qualified Propellor.Property.Sudo as Sudo
 import qualified Propellor.Property.User as User
---import qualified Propellor.Property.Hostname as Hostname
---import qualified Propellor.Property.Tor as Tor
 
 main :: IO ()
 main = defaultMain hosts
@@ -31,6 +25,5 @@ mybox = host "mybox.example.com" $ props
 	& Apt.installed ["etckeeper"]
 	& Apt.installed ["ssh"]
 	& User.hasSomePassword (User "root")
-	& Network.ipv6to4
 	& File.dirExists "/var/www"
 	& Cron.runPropellor (Cron.Times "30 * * * *")
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 6e974efd..832faf9c 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -7,11 +7,11 @@ import Propellor.Types.MetaTypes
 import Propellor.Types.Info
 import Propellor.PrivData
 
-class Container c where
+class IsContainer c where
 	containerProperties :: c -> [ChildProperty]
 	containerInfo :: c -> Info
 
-instance Container Host where
+instance IsContainer Host where
 	 containerProperties = hostProperties
 	 containerInfo = hostInfo
 
@@ -28,7 +28,7 @@ propagateContainer
 		-- Since the children being added probably have info,
 		-- require the Property's metatypes to have info.
 		( IncludesInfo metatypes ~ 'True
-		, Container c
+		, IsContainer c
 		)
 	=> String
 	-> c
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index af362ca7..1212ef7a 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -12,6 +12,8 @@ module Propellor.PropAccum
 	, (&)
 	, (&^)
 	, (!)
+	, hostProps
+	, modifyHostProps
 	) where
 
 import Propellor.Types
@@ -30,6 +32,16 @@ import Prelude
 host :: HostName -> Props metatypes -> Host
 host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
 
+-- | Note that the metatype of a Host's properties is not retained,
+-- so this defaults to UnixLike. So, using this with modifyHostProps can
+-- add properties to a Host that conflict with properties already in it.
+-- Use caution when using this.
+hostProps :: Host -> Props UnixLike
+hostProps = Props . hostProperties
+
+modifyHostProps :: Host -> Props metatypes -> Host
+modifyHostProps h ps = host (hostName h) ps
+
 -- | Props is a combination of a list of properties, with their combined 
 -- metatypes.
 data Props metatypes = Props [ChildProperty]
@@ -81,3 +93,9 @@ 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)])
+
+-- addPropsHost :: Host -> [Prop] -> Host
+-- addPropsHost (Host hn ps i) p = Host hn ps' i'
+--   where
+-- 	ps' = ps ++ [toChildProperty p]
+-- 	i' = i <> getInfoRecursive p
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index a0f3aca8..ddadc763 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -41,7 +41,7 @@ import System.Console.Concurrent
 data Chroot where
 	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
 
-instance Container Chroot where
+instance IsContainer Chroot where
 	containerProperties (Chroot _ _ h) = containerProperties h
 	containerInfo (Chroot _ _ h) = containerInfo h
 
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 8fe607bc..005fc804 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -83,7 +83,7 @@ import qualified Data.Set as S
 
 -- | Class of things that can be conducted.
 class Conductable c where
-	conducts :: c -> RevertableProperty (HasInfo + DebianLike) (HasInfo + UnixLike)
+	conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
 
 instance Conductable Host where
 	-- | Conduct the specified host.
@@ -219,8 +219,8 @@ orchestrate hs = map go hs
 	os = extractOrchestras hs
 
 	removeold h = foldl removeold' h (oldconductorsof h)
-	removeold' h oldconductor = addPropHost h $
-		undoRevertableProperty $ conductedBy oldconductor
+	removeold' h oldconductor = modifyHostProps h $ hostProps h
+		! conductedBy oldconductor
 
 	oldconductors = zip hs (map (fromInfo . hostInfo) hs)
 	oldconductorsof h = flip mapMaybe oldconductors $ 
@@ -233,22 +233,17 @@ orchestrate' :: Host -> Orchestra -> Host
 orchestrate' h (Conducted _) = h
 orchestrate' h (Conductor c l)
 	| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
-	| any (sameHost h) (map topHost l) = cont $ addPropHost h $
-		setupRevertableProperty $ conductedBy c
+	| any (sameHost h) (map topHost l) = cont $
+		modifyHostProps h $ hostProps h
+			& conductedBy c
 	| otherwise = cont h
   where
 	cont h' = foldl orchestrate' h' l
 
-addPropHost :: Host -> Property i -> Host
-addPropHost (Host hn ps i) p = Host hn ps' i'
-  where
-	ps' = ps ++ [toChildProperty p]
-	i' = i <> getInfoRecursive p
-
 -- The host this property is added to becomes the conductor for the
 -- specified Host. Note that `orchestrate` must be used for this property
 -- to have any effect.
-conductorFor :: Host -> Property (HasInfo + DebianLike)
+conductorFor :: Host -> Property (HasInfo + UnixLike)
 conductorFor h = go
 	`addInfoProperty` (toInfo (ConductorFor [h]))
 	`requires` setupRevertableProperty (conductorKnownHost h)
@@ -302,7 +297,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
 	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
+conductedBy :: Host -> RevertableProperty UnixLike UnixLike
 conductedBy h = (setup <!> teardown)
 	`describe` ("conducted by " ++ hostName h)
   where
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 6200f856..48df7fab 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -76,16 +76,16 @@ type DiskImage = FilePath
 -- chroot while the disk image is being built, which should prevent any
 -- daemons that are included from being started on the system that is
 -- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
 imageBuilt = imageBuilt' False
 
 -- | Like 'built', but the chroot is deleted and rebuilt from scratch each
 -- time. This is more expensive, but useful to ensure reproducible results
 -- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
 imageRebuilt = imageBuilt' True
 
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
 imageBuilt' rebuild img mkchroot tabletype final partspec = 
 	imageBuiltFrom img chrootdir tabletype final partspec
 		`requires` Chroot.provisioned chroot
@@ -109,7 +109,7 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
 		& Apt.cacheCleaned
 
 -- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux
 imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
   where
 	desc = img ++ " built from " ++ chrootdir
@@ -135,7 +135,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 		imageFinalized final mnts mntopts devs parttable
 	rmimg = File.notPresent img
 
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
 partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
   where
 	desc = "partitions populated from " ++ chrootdir
@@ -203,7 +203,7 @@ getMountSz szm l (Just mntpt) =
 -- If the file doesn't exist, or is too small, creates a new one, full of 0's.
 --
 -- If the file is too large, truncates it down to the specified size.
-imageExists :: FilePath -> ByteSize -> Property NoInfo
+imageExists :: FilePath -> ByteSize -> Property Linux
 imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
 	ms <- catchMaybeIO $ getFileStatus img
 	case ms of
@@ -226,9 +226,9 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
 -- 
 -- It's ok if the second property leaves additional things mounted
 -- in the partition tree.
-type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
 
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo
+imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
 imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = 
 	property "disk image finalized" $ 
 		withTmpDir "mnt" $ \top -> 
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index fe1e3b18..041e1987 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
 
 -- | Docker support for propellor
 --
@@ -50,6 +50,7 @@ import Propellor.Types.Docker
 import Propellor.Types.Container
 import Propellor.Types.CmdLine
 import Propellor.Types.Info
+import Propellor.Container
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Cmd as Cmd
@@ -71,11 +72,12 @@ installed = Apt.installed ["docker.io"]
 
 -- | Configures docker with an authentication file, so that images can be
 -- pushed to index.docker.io. Optional.
-configured :: Property DebianLike
+configured :: Property (HasInfo + DebianLike)
 configured = prop `requires` installed
   where
+	prop :: Property (HasInfo + DebianLike)
 	prop = withPrivData src anyContext $ \getcfg ->
-		property "docker configured" $ getcfg $ \cfg -> ensureProperty $
+		property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
 			"/root/.dockercfg" `File.hasContent` privDataLines cfg
 	src = PrivDataSourceFileFromCommand DockerAuthentication
 		"/root/.dockercfg" "docker login"
@@ -88,6 +90,10 @@ type ContainerName = String
 -- | A docker container.
 data Container = Container Image Host
 
+instance IsContainer Container where
+	containerProperties (Container _ h) = containerProperties h
+	containerInfo (Container _ h) = containerInfo h
+
 class HasImage a where
 	getImageName :: a -> Image
 
@@ -104,7 +110,7 @@ instance HasImage Container where
 -- >    & publish "80:80"
 -- >    & Apt.installed {"apache2"]
 -- >    & ...
-container :: ContainerName -> Image -> Props -> Container
+container :: ContainerName -> Image -> Props metatypes -> Container
 container cn image (Props ps) = Container image (Host cn ps info)
   where
 	info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
@@ -119,7 +125,7 @@ container cn image (Props ps) = Container image (Host cn ps info)
 --
 -- Reverting this property ensures that the container is stopped and
 -- removed.
-docked :: Container -> RevertableProperty HasInfo
+docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
 docked ctr@(Container _ h) =
 	(propagateContainerInfo ctr (go "docked" setup))
 		<!>
@@ -127,11 +133,12 @@ docked ctr@(Container _ h) =
   where
 	cn = hostName h
 
-	go desc a = property (desc ++ " " ++ cn) $ do
+	go desc a = property' (desc ++ " " ++ cn) $ \w -> do
 		hn <- asks hostName
 		let cid = ContainerId hn cn
-		ensureChildProperties [a cid (mkContainerInfo cid ctr)]
+		ensureProperty w $ a cid (mkContainerInfo cid ctr)
 
+	setup :: ContainerId -> ContainerInfo -> Property Linux
 	setup cid (ContainerInfo image runparams) =
 		provisionContainer cid
 			`requires`
@@ -139,8 +146,9 @@ docked ctr@(Container _ h) =
 			`requires`
 		installed
 
+	teardown :: ContainerId -> ContainerInfo -> Property Linux
 	teardown cid (ContainerInfo image _runparams) =
-		combineProperties ("undocked " ++ fromContainerId cid)
+		combineProperties ("undocked " ++ fromContainerId cid) $ toProps
 			[ stoppedContainer cid
 			, property ("cleaned up " ++ fromContainerId cid) $
 				liftIO $ report <$> mapM id
@@ -151,31 +159,31 @@ docked ctr@(Container _ h) =
 
 -- | Build the image from a directory containing a Dockerfile.
 imageBuilt :: HasImage c => FilePath -> c -> Property Linux
-imageBuilt directory ctr = describe built msg
+imageBuilt directory ctr = built `describe` msg
   where
 	msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
-	built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
-		`assume` MadeChange
+	built :: Property Linux
+	built = tightenTargets $
+		Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
+			`assume` MadeChange
 	workDir p = p { cwd = Just directory }
 	image = getImageName ctr
 
 -- | Pull the image from the standard Docker Hub registry.
 imagePulled :: HasImage c => c -> Property Linux
-imagePulled ctr = describe pulled msg
+imagePulled ctr = pulled `describe` msg
   where
 	msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
-	pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
-		`assume` MadeChange
+	pulled :: Property Linux
+	pulled = tightenTargets $ 
+		Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
+			`assume` MadeChange
 	image = getImageName ctr
 
-propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property (HasInfo + Linux)
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
+propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
+propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
+	p `addInfoProperty'` dockerinfo
   where
-	p' = infoProperty
-		(getDesc p)
-		(getSatisfy p)
-		(getInfo p <> dockerinfo)
-		(propertyChildren p)
 	dockerinfo = dockerInfo $
 		mempty { _dockerContainers = M.singleton cn h }
 	cn = hostName h
@@ -187,7 +195,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
 	runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
 		(_dockerRunParams info)
 	info = fromInfo $ hostInfo h'
-	h' = h
+	h' = modifyHostProps h $ hostProps h
 		-- Restart by default so container comes up on
 		-- boot or when docker is upgraded.
 		&^ restartAlways
@@ -209,8 +217,10 @@ garbageCollected = propertyList "docker garbage collected" $ props
 	& gccontainers
 	& gcimages
   where
+	gccontainers :: Property Linux
 	gccontainers = property "docker containers garbage collected" $
 		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
+	gcimages :: Property Linux
 	gcimages = property "docker images garbage collected" $
 		liftIO $ report <$> (mapM removeImage =<< listImages)
 
@@ -220,7 +230,7 @@ garbageCollected = propertyList "docker garbage collected" $ props
 -- the pam config, to work around <https://github.com/docker/docker/issues/5663>
 -- which affects docker 1.2.0.
 tweaked :: Property Linux
-tweaked = cmdProperty "sh"
+tweaked = tightenTargets $ cmdProperty "sh"
 	[ "-c"
 	, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
 	]
@@ -234,9 +244,10 @@ tweaked = cmdProperty "sh"
 --
 -- Only takes effect after reboot. (Not automated.)
 memoryLimited :: Property DebianLike
-memoryLimited = "/etc/default/grub" `File.containsLine` cfg
-	`describe` "docker memory limited"
-	`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+memoryLimited = tightenTargets $
+	"/etc/default/grub" `File.containsLine` cfg
+		`describe` "docker memory limited"
+		`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
   where
 	cmdline = "cgroup_enable=memory swapaccount=1"
 	cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
@@ -294,15 +305,15 @@ instance ImageIdentifier ImageUID where
 	imageIdentifier (ImageUID uid) = uid
 
 -- | Set custom dns server for container.
-dns :: String -> Property HasInfo
+dns :: String -> Property (HasInfo + Linux)
 dns = runProp "dns"
 
 -- | Set container host name.
-hostname :: String -> Property HasInfo
+hostname :: String -> Property (HasInfo + Linux)
 hostname = runProp "hostname"
 
 -- | Set name of container.
-name :: String -> Property HasInfo
+name :: String -> Property (HasInfo + Linux)
 name = runProp "name"
 
 class Publishable p where
@@ -316,15 +327,15 @@ instance Publishable String where
 	toPublish = id
 
 -- | Publish a container's port to the host
-publish :: Publishable p => p -> Property HasInfo
+publish :: Publishable p => p -> Property (HasInfo + Linux)
 publish = runProp "publish" . toPublish
 
 -- | Expose a container's port without publishing it.
-expose :: String -> Property HasInfo
+expose :: String -> Property (HasInfo + Linux)
 expose = runProp "expose"
 
 -- | Username or UID for container.
-user :: String -> Property HasInfo
+user :: String -> Property (HasInfo + Linux)
 user = runProp "user"
 
 class Mountable p where
@@ -340,17 +351,17 @@ instance Mountable String where
 	toMount = id
 
 -- | Mount a volume
-volume :: Mountable v => v -> Property HasInfo
+volume :: Mountable v => v -> Property (HasInfo + Linux)
 volume = runProp "volume" . toMount
 
 -- | Mount a volume from the specified container into the current
 -- container.
-volumes_from :: ContainerName -> Property HasInfo
+volumes_from :: ContainerName -> Property (HasInfo + Linux)
 volumes_from cn = genProp "volumes-from" $ \hn ->
 	fromContainerId (ContainerId hn cn)
 
 -- | Work dir inside the container.
-workdir :: String -> Property HasInfo
+workdir :: String -> Property (HasInfo + Linux)
 workdir = runProp "workdir"
 
 -- | Memory limit for container.
@@ -358,18 +369,18 @@ workdir = runProp "workdir"
 --
 -- Note: Only takes effect when the host has the memoryLimited property
 -- enabled.
-memory :: String -> Property HasInfo
+memory :: String -> Property (HasInfo + Linux)
 memory = runProp "memory"
 
 -- | CPU shares (relative weight).
 --
 -- By default, all containers run at the same priority, but you can tell
 -- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property HasInfo
+cpuShares :: Int -> Property (HasInfo + Linux)
 cpuShares = runProp "cpu-shares" . show
 
 -- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property HasInfo
+link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
 link linkwith calias = genProp "link" $ \hn ->
 	fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
 
@@ -381,24 +392,24 @@ type ContainerAlias = String
 -- propellor; as well as keeping badly behaved containers running,
 -- it ensures that containers get started back up after reboot or
 -- after docker is upgraded.
-restartAlways :: Property HasInfo
+restartAlways :: Property (HasInfo + Linux)
 restartAlways = runProp "restart" "always"
 
 -- | Docker will restart the container if it exits nonzero.
 -- If a number is provided, it will be restarted only up to that many
 -- times.
-restartOnFailure :: Maybe Int -> Property HasInfo
+restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
 restartOnFailure Nothing = runProp "restart" "on-failure"
 restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
 
 -- | Makes docker not restart a container when it exits
 -- Note that this includes not restarting it on boot!
-restartNever :: Property HasInfo
+restartNever :: Property (HasInfo + Linux)
 restartNever = runProp "restart" "no"
 
 -- | Set environment variable with a tuple composed by the environment
 -- variable name and its value.
-environment :: (String, String) -> Property HasInfo
+environment :: (String, String) -> Property (HasInfo + Linux)
 environment (k, v) = runProp "env" $ k ++ "=" ++ v
 
 -- | A container is identified by its name, and the host
@@ -501,6 +512,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 				retry (n-1) a
 			_ -> return v
 
+	go :: ImageIdentifier i => i -> Propellor Result
 	go img = liftIO $ do
 		clearProvisionedFlag cid
 		createDirectoryIfMissing True (takeDirectory $ identFile cid)
@@ -592,14 +604,15 @@ startContainer :: ContainerId -> IO Bool
 startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
 
 stoppedContainer :: ContainerId -> Property Linux
-stoppedContainer cid = containerDesc cid $ property' desc $ \o ->
+stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
 	ifM (liftIO $ elem cid <$> listContainers RunningContainers)
-		( liftIO cleanup `after` ensureProperty o
-			(property desc $ liftIO $ toResult <$> stopContainer cid)
+		( liftIO cleanup `after` ensureProperty w stop
 		, return NoChange
 		)
   where
 	desc = "stopped"
+	stop :: Property Linux
+	stop = property desc $ liftIO $ toResult <$> stopContainer cid
 	cleanup = do
 		nukeFile $ identFile cid
 		removeDirectoryRecursive $ shimdir cid
@@ -643,14 +656,14 @@ listContainers status =
 listImages :: IO [ImageUID]
 listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
 
-runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $
+runProp :: String -> RunParam -> Property (HasInfo + Linux)
+runProp field val = tightenTargets $ pureInfoProperty (param) $
 	mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
   where
 	param = field++"="++val
 
-genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $
+genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
+genProp field mkval = tightenTargets $ pureInfoProperty field $
 	mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
 
 dockerInfo :: DockerInfo -> Info
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index bfe3ae17..5c4788e2 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -6,19 +6,24 @@ import qualified Propellor.Property.File as File
 import qualified Propellor.Property.User as User
 
 -- Clean up a system as installed by cloudatcost.com
-decruft :: Property NoInfo
-decruft = propertyList "cloudatcost cleanup"
-	[ Hostname.sane
-	, "worked around grub/lvm boot bug #743126" ==>
+decruft :: Property DebianLike
+decruft = propertyList "cloudatcost cleanup" $ props
+	& Hostname.sane
+	& grubbugfix
+	& nukecruft
+  where
+	grubbugfix :: Property DebianLike
+	grubbugfix = tightenTargets $ 
 		"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
-		`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
-		`onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
-	, combineProperties "nuked cloudatcost cruft"
-		[ File.notPresent "/etc/rc.local"
-		, File.notPresent "/etc/init.d/S97-setup.sh"
-		, File.notPresent "/zang-debian.sh"
-		, File.notPresent "/bin/npasswd"
-		, User.nuked (User "user") User.YesReallyDeleteHome
-		]
-	]
+			`describe` "worked around grub/lvm boot bug #743126"
+			`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+			`onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
+	nukecruft :: Property Linux
+	nukecruft = tightenTargets $
+		combineProperties "nuked cloudatcost cruft" $ props
+			& File.notPresent "/etc/rc.local"
+			& File.notPresent "/etc/init.d/S97-setup.sh"
+			& File.notPresent "/zang-debian.sh"
+			& File.notPresent "/bin/npasswd"
+			& User.nuked (User "user") User.YesReallyDeleteHome
 
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 7ab350ae..e1342d91 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -22,20 +22,20 @@ import Data.List.Utils
 -- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any
 -- other hostnames there is not best practices and can lead to annoying
 -- messages from eg, apache.
-sane :: Property NoInfo
+sane :: Property UnixLike
 sane = sane' extractDomain
 
-sane' :: ExtractDomain -> Property NoInfo
-sane' extractdomain = property ("sane hostname") $
-	ensureProperty . setTo' extractdomain =<< asks hostName
+sane' :: ExtractDomain -> Property UnixLike
+sane' extractdomain = property' ("sane hostname") $ \w ->
+	ensureProperty w . setTo' extractdomain =<< asks hostName
 
 -- Like `sane`, but you can specify the hostname to use, instead
 -- of the default hostname of the `Host`.
-setTo :: HostName -> Property NoInfo
+setTo :: HostName -> Property UnixLike
 setTo = setTo' extractDomain
 
-setTo' :: ExtractDomain -> HostName -> Property NoInfo
-setTo' extractdomain hn = combineProperties desc
+setTo' :: ExtractDomain -> HostName -> Property UnixLike
+setTo' extractdomain hn = combineProperties desc $ toProps
 	[ "/etc/hostname" `File.hasContent` [basehost]
 	, hostslines $ catMaybes
 		[ if null domain
@@ -65,11 +65,12 @@ setTo' extractdomain hn = combineProperties desc
 
 -- | Makes </etc/resolv.conf> contain search and domain lines for 
 -- the domain that the hostname is in.
-searchDomain :: Property NoInfo
+searchDomain :: Property UnixLike
 searchDomain = searchDomain' extractDomain
 
-searchDomain' :: ExtractDomain -> Property NoInfo
-searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)
+searchDomain' :: ExtractDomain -> Property UnixLike
+searchDomain' extractdomain = property' desc $ \w ->
+	(ensureProperty w . go =<< asks hostName)
   where
 	desc = "resolv.conf search and domain configured"
 	go hn =
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index dc4b7a75..05409593 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -47,8 +47,13 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.List
 
-installed :: Property DebianLike
-installed = Apt.installed ["ssh"]
+installed :: Property UnixLike
+installed = withOS "ssh installed" $ \w o -> 
+	let aptinstall = ensureProperty w $ Apt.installed ["ssh"]
+	in case o of
+		(Just (System (Debian _) _)) -> aptinstall
+		(Just (System (Buntish _) _)) -> aptinstall
+		_ -> unsupportedOS
 
 restarted :: Property DebianLike
 restarted = Service.restarted "ssh"
-- 
cgit v1.3-2-g0d8e


From 0b0ea182ab3301ade8b87b1be1cdecc3464cd1da Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 27 Mar 2016 16:10:43 -0400
Subject: ported DiskImage

Unfortunately, DiskImage needs to add properties to the Chroot it's
presented with, and the metatypes are not included in the Chroot, so it
can't guarantee that the properties it's adding match the OS in the Chroot.

I partially worked around this by making the properties that DiskImage adds
check the OS, so they don't assume Debian.

It would be nicer to parameterize the Chroot type with the metatypes of the
inner OS. I worked for several hours on a patch along those lines, but it
doesn't quite compile. Failed at the final hurdle :/ The patch is below
for later..

--- src/Propellor/Property/Chroot.hs	2016-03-27 16:06:44.285464820 -0400
+++ /home/joey/Chroot.hs	2016-03-27 15:32:29.073416143 -0400
@@ -1,9 +1,9 @@
-{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DataKinds #-}

 module Propellor.Property.Chroot (
 	debootstrapped,
 	bootstrapped,
-	provisioned,
+	--provisioned,
 	Chroot(..),
 	ChrootBootstrapper(..),
 	Debootstrapped(..),
@@ -11,7 +11,7 @@
 	noServices,
 	inChroot,
 	-- * Internal use
-	provisioned',
+	--provisioned',
 	propagateChrootInfo,
 	propellChroot,
 	chain,
@@ -20,6 +20,7 @@

 import Propellor.Base
 import Propellor.Container
+import Propellor.Types.MetaTypes
 import Propellor.Types.CmdLine
 import Propellor.Types.Chroot
 import Propellor.Types.Info
@@ -38,27 +39,29 @@

 -- | Specification of a chroot. Normally you'll use `debootstrapped` or
 -- `bootstrapped` to construct a Chroot value.
-data Chroot where
-	Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
-
-instance IsContainer Chroot where
-	containerProperties (Chroot _ _ h) = containerProperties h
-	containerInfo (Chroot _ _ h) = containerInfo h
-	setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
+--
+-- The inner and outer type variables are the metatypes of the inside of
+-- the chroot and the system it runs in.
+data Chroot inner outer where
+	Chroot :: ChrootBootstrapper b inner outer => FilePath -> b -> Host -> (inner, outer) -> Chroot inner outer
+
+instance IsContainer (Chroot inner outer) where
+	containerProperties (Chroot _ _ h _) = containerProperties h
+	containerInfo (Chroot _ _ h _) = containerInfo h

-chrootSystem :: Chroot -> Maybe System
+chrootSystem :: Chroot inner outer -> Maybe System
 chrootSystem = fromInfoVal . fromInfo . containerInfo

-instance Show Chroot where
-	show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
+instance Show (Chroot inner outer) where
+	show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)

 -- | Class of things that can do initial bootstrapping of an operating
 -- System in a chroot.
-class ChrootBootstrapper b where
+class ChrootBootstrapper b inner outer 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 Linux)
+	buildchroot :: b -> Maybe System -> FilePath -> Either String (Property outer)

 -- | Use this to bootstrap a chroot by extracting a tarball.
 --
@@ -68,9 +71,8 @@
 -- detect automatically.
 data ChrootTarball = ChrootTarball FilePath

-instance ChrootBootstrapper ChrootTarball where
-	buildchroot (ChrootTarball tb) _ loc = Right $
-		tightenTargets $ extractTarball loc tb
+instance ChrootBootstrapper ChrootTarball UnixLike UnixLike where
+	buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb

 extractTarball :: FilePath -> FilePath -> Property UnixLike
 extractTarball target src = check (unpopulated target) $
@@ -88,7 +90,7 @@
 -- | Use this to bootstrap a chroot with debootstrap.
 data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig

-instance ChrootBootstrapper Debootstrapped where
+instance ChrootBootstrapper Debootstrapped DebianLike Linux where
 	buildchroot (Debootstrapped cf) system loc = case system of
 		(Just s@(System (Debian _) _)) -> Right $ debootstrap s
 		(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
@@ -107,13 +109,22 @@
 -- >	& osDebian Unstable "amd64"
 -- >	& Apt.installed ["ghc", "haskell-platform"]
 -- >	& ...
-debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+-- debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot DebianLike
+debootstrapped
+	:: (SingI inner, SingI outer, ChrootBootstrapper Debootstrapped (MetaTypes inner) (MetaTypes outer))
+	=> Debootstrap.DebootstrapConfig
+	-> FilePath
+	-> Chroot (MetaTypes inner) (MetaTypes outer)
 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
+bootstrapped
+	:: (SingI inner, SingI outer, ChrootBootstrapper b (MetaTypes inner) (MetaTypes outer))
+	=> b
+	-> FilePath
+	-> Chroot (MetaTypes inner) (MetaTypes outer)
+bootstrapped bootstrapper location = Chroot location bootstrapper h (sing, sing)
   where
 	h = Host location [] mempty

@@ -123,45 +134,79 @@
 -- Reverting this property removes the chroot. Anything mounted inside it
 -- is first unmounted. Note that it does not ensure that any processes
 -- that might be running inside the chroot are stopped.
-provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
+-- provisioned :: SingI outer => Chroot inner outer -> RevertableProperty (HasInfo + MetaTypes outer) Linux
+provisioned
+	::
+		( SingI outer
+		, SingI metatypes
+		, Combines (Property (MetaTypes outer)) (Property (MetaTypes outer))
+		, (HasInfo + outer) ~ MetaTypes metatypes
+		, CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer
+		, IncludesInfo (MetaTypes metatypes) ~ 'True)
+	=> Chroot inner outer -> RevertableProperty (HasInfo + outer) Linux
 provisioned c = provisioned' (propagateChrootInfo c) c False

 provisioned'
-	:: (Property Linux -> Property (HasInfo + Linux))
-	-> Chroot
+	::
+		( Combines (Property (MetaTypes outer)) (Property (MetaTypes outer))
+		, CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer
+		, SingI outer
+		)
+	=> (Property outer -> Property (HasInfo + outer))
+	-> Chroot inner outer
 	-> Bool
-	-> RevertableProperty (HasInfo + Linux) Linux
-provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
-	(propigator $ setup `describe` chrootDesc c "exists")
+	-> RevertableProperty (HasInfo + outer) Linux
+provisioned' propigator c systemdonly =
+	(propigator $ setup c systemdonly `describe` chrootDesc c "exists")
 		<!>
-	(teardown `describe` chrootDesc c "removed")
-  where
-	setup :: Property Linux
-	setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
-		`requires` built
-
-	built = case buildchroot bootstrapper (chrootSystem c) loc of
-		Right p -> p
-		Left e -> cantbuild e
-
-	cantbuild e = property (chrootDesc c "built") (error e)
-
-	teardown :: Property Linux
-	teardown = check (not <$> unpopulated loc) $
-		property ("removed " ++ loc) $
-			makeChange (removeChroot loc)
-
-propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
-	p `addInfoProperty` chrootInfo c
+	(teardown c `describe` chrootDesc c "removed")

-chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ h) = mempty `addInfo`
+-- chroot removal code is currently linux specific..
+teardown :: Chroot inner outer -> Property Linux
+teardown (Chroot loc _ _ _) = check (not <$> unpopulated loc) $
+	property ("removed " ++ loc) $
+		makeChange (removeChroot loc)
+
+setup
+	::
+		( SingI outer
+		, Combines (Property (MetaTypes outer)) (Property (MetaTypes outer))
+		)
+	=> Chroot inner outer
+	-> Bool
+	-> CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer))
+setup c systemdonly = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
+	`requires` built c
+
+built :: (SingI outer, ChrootBootstrapper b inner outer) => Chroot inner outer -> Property (MetaTypes outer)
+built c@(Chroot loc bootstrapper _ _) =
+	case buildchroot bootstrapper (chrootSystem c) loc of
+		Right p -> error "FOO" -- p
+		Left e -> error "FOO" -- cantbuild c e
+
+cantbuild :: Chroot inner outer -> String -> Property UnixLike
+cantbuild c e = property (chrootDesc c "built") (error e)
+
+propagateChrootInfo
+	::
+		( SingI metatypes
+		, (HasInfo + outer) ~ MetaTypes metatypes
+		, IncludesInfo (MetaTypes metatypes) ~ 'True
+		)
+	=> Chroot inner outer
+	-> Property outer
+	-> Property (MetaTypes metatypes)
+propagateChrootInfo c@(Chroot location _ _ _) p =
+	propagateContainer location c $
+		p `addInfoProperty` chrootInfo c
+
+chrootInfo :: Chroot inner outer -> Info
+chrootInfo (Chroot loc _ h _) = mempty `addInfo`
 	mempty { _chroots = M.singleton loc h }

 -- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
-propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
+propellChroot :: SingI outer => Chroot inner outer -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property (MetaTypes outer)
+propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
 	let d = localdir </> shimdir c
 	let me = localdir </> "propellor"
 	shim <- liftIO $ ifM (doesDirectoryExist d)
@@ -199,8 +244,8 @@
 		liftIO cleanup
 		return r

-toChain :: HostName -> Chroot -> Bool -> IO CmdLine
-toChain parenthost (Chroot loc _ _) systemdonly = do
+toChain :: HostName -> Chroot inner outer -> Bool -> IO CmdLine
+toChain parenthost (Chroot loc _ _ _) systemdonly = do
 	onconsole <- isConsole <$> getMessageHandle
 	return $ ChrootChain parenthost loc systemdonly onconsole

@@ -224,8 +269,8 @@
 			putStrLn $ "\n" ++ show r
 chain _ _ = errorMessage "bad chain command"

-inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
-inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
+inChrootProcess :: Bool -> Chroot inner outer -> [String] -> IO (CreateProcess, IO ())
+inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
 	mountproc
 	return (proc "chroot" (loc:cmd), cleanup)
   where
@@ -244,26 +289,24 @@
 provisioningLock :: FilePath -> FilePath
 provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"

-shimdir :: Chroot -> FilePath
-shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim"
+shimdir :: Chroot inner outer -> FilePath
+shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"

 mungeloc :: FilePath -> String
 mungeloc = replace "/" "_"

-chrootDesc :: Chroot -> String -> String
-chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
+chrootDesc :: Chroot inner outer -> String -> String
+chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc
---
 src/Propellor/Container.hs          | 18 ++++++++-
 src/Propellor/PropAccum.hs          | 12 ------
 src/Propellor/Property.hs           |  2 +-
 src/Propellor/Property/Chroot.hs    | 11 +++--
 src/Propellor/Property/Conductor.hs |  7 ++--
 src/Propellor/Property/DiskImage.hs | 81 ++++++++++++++++++++++---------------
 src/Propellor/Property/Grub.hs      | 11 +++--
 src/Propellor/Property/Ssh.hs       |  2 +-
 src/Propellor/Types/MetaTypes.hs    |  2 +-
 9 files changed, 87 insertions(+), 59 deletions(-)

(limited to 'src/Propellor/Property/Chroot.hs')

diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 832faf9c..4cd46ae5 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -6,14 +6,28 @@ import Propellor.Types
 import Propellor.Types.MetaTypes
 import Propellor.Types.Info
 import Propellor.PrivData
+import Propellor.PropAccum
 
 class IsContainer c where
 	containerProperties :: c -> [ChildProperty]
 	containerInfo :: c -> Info
+	setContainerProperties :: c -> [ChildProperty] -> c
 
 instance IsContainer Host where
-	 containerProperties = hostProperties
-	 containerInfo = hostInfo
+	containerProperties = hostProperties
+	containerInfo = hostInfo
+	setContainerProperties h ps = host (hostName h) (Props ps)
+
+-- | Note that the metatype of a container's properties is not retained,
+-- so this defaults to UnixLike. So, using this with setContainerProps can
+-- add properties to a container that conflict with properties already in it.
+-- Use caution when using this; only add properties that do not have
+-- restricted targets.
+containerProps :: IsContainer c => c -> Props UnixLike
+containerProps = Props . containerProperties
+
+setContainerProps :: IsContainer c => c -> Props metatypes -> c
+setContainerProps c (Props ps) = setContainerProperties c ps
 
 -- | Adjust the provided Property, adding to its
 -- propertyChidren the properties of the provided container.
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 1212ef7a..856f2e8e 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -12,8 +12,6 @@ module Propellor.PropAccum
 	, (&)
 	, (&^)
 	, (!)
-	, hostProps
-	, modifyHostProps
 	) where
 
 import Propellor.Types
@@ -32,16 +30,6 @@ import Prelude
 host :: HostName -> Props metatypes -> Host
 host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
 
--- | Note that the metatype of a Host's properties is not retained,
--- so this defaults to UnixLike. So, using this with modifyHostProps can
--- add properties to a Host that conflict with properties already in it.
--- Use caution when using this.
-hostProps :: Host -> Props UnixLike
-hostProps = Props . hostProperties
-
-modifyHostProps :: Host -> Props metatypes -> Host
-modifyHostProps h ps = host (hostName h) ps
-
 -- | Props is a combination of a list of properties, with their combined 
 -- metatypes.
 data Props metatypes = Props [ChildProperty]
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 9fa29888..70583edc 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -308,7 +308,7 @@ makeChange a = liftIO a >> return MadeChange
 noChange :: Propellor Result
 noChange = return NoChange
 
-doNothing :: Property UnixLike
+doNothing :: SingI t => Property (MetaTypes t)
 doNothing = property "noop property" noChange
 
 -- | Registers an action that should be run at the very end, after
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ddadc763..b29da7f9 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -44,6 +44,7 @@ data Chroot where
 instance IsContainer Chroot where
 	containerProperties (Chroot _ _ h) = containerProperties h
 	containerInfo (Chroot _ _ h) = containerInfo h
+	setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
 
 chrootSystem :: Chroot -> Maybe System
 chrootSystem = fromInfoVal . fromInfo . containerInfo
@@ -256,11 +257,13 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
 -- from being started, which is often something you want to prevent when
 -- building a chroot.
 --
--- This is accomplished by installing a </usr/sbin/policy-rc.d> script
--- that does not let any daemons be started by packages that use
+-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>
+-- script that does not let any daemons be started by packages that use
 -- invoke-rc.d. Reverting the property removes the script.
-noServices :: RevertableProperty DebianLike DebianLike
-noServices = tightenTargets setup <!> tightenTargets teardown
+--
+-- This property has no effect on non-Debian systems.
+noServices :: RevertableProperty UnixLike UnixLike
+noServices = setup <!> teardown
   where
 	f = "/usr/sbin/policy-rc.d"
 	script = [ "#!/bin/sh", "exit 101" ]
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 005fc804..ab747acc 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -74,6 +74,7 @@ module Propellor.Property.Conductor (
 ) where
 
 import Propellor.Base
+import Propellor.Container
 import Propellor.Spin (spin')
 import Propellor.PrivData.Paths
 import Propellor.Types.Info
@@ -219,7 +220,7 @@ orchestrate hs = map go hs
 	os = extractOrchestras hs
 
 	removeold h = foldl removeold' h (oldconductorsof h)
-	removeold' h oldconductor = modifyHostProps h $ hostProps h
+	removeold' h oldconductor = setContainerProps h $ containerProps h
 		! conductedBy oldconductor
 
 	oldconductors = zip hs (map (fromInfo . hostInfo) hs)
@@ -234,7 +235,7 @@ orchestrate' h (Conducted _) = h
 orchestrate' h (Conductor c l)
 	| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
 	| any (sameHost h) (map topHost l) = cont $
-		modifyHostProps h $ hostProps h
+		setContainerProps h $ containerProps h
 			& conductedBy c
 	| otherwise = cont h
   where
@@ -268,7 +269,7 @@ conductorFor h = go
 
 -- Reverts conductorFor.
 notConductorFor :: Host -> Property (HasInfo + UnixLike)
-notConductorFor h = doNothing
+notConductorFor h = (doNothing :: Property UnixLike)
 	`addInfoProperty` (toInfo (NotConductorFor [h]))
 	`describe` desc
 	`requires` undoRevertableProperty (conductorKnownHost h)
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 48df7fab..8c027b05 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,6 +2,8 @@
 --
 -- This module is designed to be imported unqualified.
 
+{-# LANGUAGE TypeFamilies #-}
+
 module Propellor.Property.DiskImage (
 	-- * Partition specification
 	module Propellor.Property.DiskImage.PartSpec,
@@ -30,6 +32,7 @@ import Propellor.Property.Parted
 import Propellor.Property.Mount
 import Propellor.Property.Partition
 import Propellor.Property.Rsync
+import Propellor.Container
 import Utility.Path
 
 import Data.List (isPrefixOf, isInfixOf, sortBy)
@@ -51,7 +54,8 @@ type DiskImage = FilePath
 --
 -- > import Propellor.Property.DiskImage
 --
--- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
+-- > let chroot d = Chroot.debootstrapped mempty d
+-- >	& osDebian Unstable "amd64"
 -- >	& Apt.installed ["linux-image-amd64"]
 -- >	& User.hasPassword (User "root")
 -- >	& User.accountFor (User "demo")
@@ -89,31 +93,44 @@ imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finaliz
 imageBuilt' rebuild img mkchroot tabletype final partspec = 
 	imageBuiltFrom img chrootdir tabletype final partspec
 		`requires` Chroot.provisioned chroot
-		`requires` (cleanrebuild <!> doNothing)
+		`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
 		`describe` desc
   where
 	desc = "built disk image " ++ img
+	cleanrebuild :: Property Linux
 	cleanrebuild
 		| rebuild = property desc $ do
 			liftIO $ removeChroot chrootdir
 			return MadeChange
 		| otherwise = doNothing
 	chrootdir = img ++ ".chroot"
-	chroot = mkchroot chrootdir
-		-- Before ensuring any other properties of the chroot, avoid
-		-- starting services. Reverted by imageFinalized.
-		&^ Chroot.noServices
-		-- First stage finalization.
-		& fst final
-		-- Avoid wasting disk image space on the apt cache
-		& Apt.cacheCleaned
+	chroot =
+		let c = mkchroot chrootdir
+		in setContainerProps c $ containerProps c
+			-- Before ensuring any other properties of the chroot,
+			-- avoid starting services. Reverted by imageFinalized.
+			&^ Chroot.noServices
+			-- First stage finalization.
+			& fst final
+			& cachesCleaned
+
+-- | This property is automatically added to the chroot when building a
+-- disk image. It cleans any caches of information that can be omitted;
+-- eg the apt cache on Debian.
+cachesCleaned :: Property UnixLike
+cachesCleaned = withOS "cache cleaned" $ \w o -> 
+	let aptclean = ensureProperty w Apt.cacheCleaned
+	in case o of
+		(Just (System (Debian _) _)) -> aptclean
+		(Just (System (Buntish _) _)) -> aptclean
+		_ -> noChange
 
 -- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
 imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
   where
 	desc = img ++ " built from " ++ chrootdir
-	mkimg = property desc $ do
+	mkimg = property' desc $ \w -> do
 		-- unmount helper filesystems such as proc from the chroot
 		-- before getting sizes
 		liftIO $ unmountBelow chrootdir
@@ -123,7 +140,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 		-- tie the knot!
 		let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
 			map (calcsz mnts) mnts
-		ensureProperty $
+		ensureProperty w $
 			imageExists img (partTableSize parttable)
 				`before`
 			partitioned YesReallyDeleteDiskContents img parttable
@@ -136,16 +153,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 	rmimg = File.notPresent img
 
 partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
-partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> 
+	mconcat $ zipWith3 (go w) mnts mntopts devs
   where
 	desc = "partitions populated from " ++ chrootdir
 
-	go Nothing _ _ = noChange
-	go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+	go _ Nothing _ _ = noChange
+	go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
 		(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
 		(const $ liftIO $ umountLazy tmpdir)
 		$ \ismounted -> if ismounted
-			then ensureProperty $
+			then ensureProperty w $
 				syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
 			else return FailedChange
 
@@ -230,15 +248,15 @@ type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
 
 imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
 imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = 
-	property "disk image finalized" $ 
+	property' "disk image finalized" $ \w ->
 		withTmpDir "mnt" $ \top -> 
-			go top `finally` liftIO (unmountall top)
+			go w top `finally` liftIO (unmountall top)
   where
-	go top = do
+	go w top = do
 		liftIO $ mountall top
 		liftIO $ writefstab top
 		liftIO $ allowservices top
-		ensureProperty $ final top devs
+		ensureProperty w $ final top devs
 	
 	-- Ordered lexographically by mount point, so / comes before /usr
 	-- comes before /usr/local
@@ -280,27 +298,26 @@ noFinalization = (doNothing, \_ _ -> doNothing)
 grubBooted :: Grub.BIOS -> Finalization
 grubBooted bios = (Grub.installed' bios, boots)
   where
-	boots mnt loopdevs = combineProperties "disk image boots using grub"
+	boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
 		-- bind mount host /dev so grub can access the loop devices
-		[ bindMount "/dev" (inmnt "/dev")
-		, mounted "proc" "proc" (inmnt "/proc") mempty
-		, mounted "sysfs" "sys" (inmnt "/sys") mempty
+		& bindMount "/dev" (inmnt "/dev")
+		& mounted "proc" "proc" (inmnt "/proc") mempty
+		& mounted "sysfs" "sys" (inmnt "/sys") mempty
 		-- update the initramfs so it gets the uuid of the root partition
-		, inchroot "update-initramfs" ["-u"]
+		& inchroot "update-initramfs" ["-u"]
 			`assume` MadeChange
 		-- work around for http://bugs.debian.org/802717
-		, check haveosprober $ inchroot "chmod" ["-x", osprober]
-		, inchroot "update-grub" []
+		& check haveosprober (inchroot "chmod" ["-x", osprober])
+		& inchroot "update-grub" []
 			`assume` MadeChange
-		, check haveosprober $ inchroot "chmod" ["+x", osprober]
-		, inchroot "grub-install" [wholediskloopdev]
+		& check haveosprober (inchroot "chmod" ["+x", osprober])
+		& inchroot "grub-install" [wholediskloopdev]
 			`assume` MadeChange
 		-- sync all buffered changes out to the disk image
 		-- may not be necessary, but seemed needed sometimes
 		-- when using the disk image right away.
-		, cmdProperty "sync" []
+		& cmdProperty "sync" []
 			`assume` NoChange
-		]
 	  where
 	  	-- cannot use </> since the filepath is absolute
 		inmnt f = mnt ++ f
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 09255587..b8dc5f9e 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -29,10 +29,15 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" []
 	`assume` MadeChange
 
 -- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property DebianLike
-installed' bios = Apt.installed [pkg] `describe` "grub package installed"
+installed' :: BIOS -> Property Linux
+installed' bios = withOS "grub package installed" $ \w o -> 
+	let apt = ensureProperty w (Apt.installed [debpkg])
+	in case o of
+		(Just (System (Debian _) _)) -> apt
+		(Just (System (Buntish _) _)) -> apt
+		_ -> unsupportedOS
   where
-	pkg = case bios of
+	debpkg = case bios of
 		PC -> "grub-pc"
 		EFI64 -> "grub-efi-amd64"
 		EFI32 -> "grub-efi-ia32"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 05409593..7048de3b 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -173,7 +173,7 @@ hostKeys ctx l = go `before` cleanup
 	removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
 	cleanup :: Property DebianLike
 	cleanup
-		| null staletypes || null l = tightenTargets doNothing
+		| null staletypes || null l = doNothing
 		| otherwise =
 			combineProperties ("any other ssh host keys removed " ++ typelist staletypes)
 				(toProps $ removestale True ++ removestale False)
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index ce2b1411..3e89e28d 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -36,7 +36,7 @@ type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targe
 -- | Any linux system
 type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
 -- | Debian and derivatives.
-type DebianLike = Debian + Buntish
+type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
 type Debian = MetaTypes '[ 'Targeting 'OSDebian ]
 type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ]
 type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ]
-- 
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 'src/Propellor/Property/Chroot.hs')

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 9d6dc29555b8499d8ae6c73c891b0b5dc19f83e5 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 27 Mar 2016 19:59:20 -0400
Subject: improve haddocks and move code around to make them more clear

---
 propellor.cabal                       |   1 +
 src/Propellor/Container.hs            |   4 +-
 src/Propellor/Engine.hs               |   4 +-
 src/Propellor/EnsureProperty.hs       |   1 +
 src/Propellor/Info.hs                 |  28 +++++-
 src/Propellor/PrivData.hs             |   2 +-
 src/Propellor/PropAccum.hs            |   5 +-
 src/Propellor/Property.hs             |   1 +
 src/Propellor/Property/Chroot.hs      |   3 +-
 src/Propellor/Property/Concurrent.hs  |   2 +
 src/Propellor/Property/Conductor.hs   |  13 +--
 src/Propellor/Property/Dns.hs         |   2 +-
 src/Propellor/Property/Docker.hs      |   3 +-
 src/Propellor/Property/FreeBSD/Pkg.hs |   4 +-
 src/Propellor/Property/List.hs        |   2 +
 src/Propellor/Property/Partition.hs   |   1 +
 src/Propellor/Property/Scheduled.hs   |   1 +
 src/Propellor/Types.hs                | 168 ++++++----------------------------
 src/Propellor/Types/Core.hs           | 106 +++++++++++++++++++++
 src/Propellor/Types/Info.hs           |   5 +
 20 files changed, 196 insertions(+), 160 deletions(-)
 create mode 100644 src/Propellor/Types/Core.hs

(limited to 'src/Propellor/Property/Chroot.hs')

diff --git a/propellor.cabal b/propellor.cabal
index f11d2afe..e946f697 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -150,6 +150,7 @@ Library
     Propellor.EnsureProperty
     Propellor.Exception
     Propellor.Types
+    Propellor.Types.Core
     Propellor.Types.Chroot
     Propellor.Types.CmdLine
     Propellor.Types.Container
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 4cd46ae5..c4d6f864 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -3,8 +3,10 @@
 module Propellor.Container where
 
 import Propellor.Types
+import Propellor.Types.Core
 import Propellor.Types.MetaTypes
 import Propellor.Types.Info
+import Propellor.Info
 import Propellor.PrivData
 import Propellor.PropAccum
 
@@ -54,7 +56,7 @@ propagateContainer containername c prop = prop
 	convert p = 
 		let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
 		    n' = n
-		    	`addInfoProperty` mapInfo (forceHostContext containername)
+		    	`setInfoProperty` mapInfo (forceHostContext containername)
 				(propagatableInfo (getInfo p))
 		   	`addChildren` map convert (getChildren p)
 		in toChildProperty n'
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 4c37e704..f0035c40 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -4,7 +4,6 @@
 module Propellor.Engine (
 	mainProperties,
 	runPropellor,
-	ensureProperty,
 	ensureChildProperties,
 	fromHost,
 	fromHost',
@@ -23,10 +22,11 @@ import Control.Applicative
 import Prelude
 
 import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Types.Core
 import Propellor.Message
 import Propellor.Exception
 import Propellor.Info
-import Propellor.Property
 import Utility.Exception
 
 -- | Gets the Properties of a Host, and ensures them all,
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index f9094c5b..ce01d436 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -11,6 +11,7 @@ module Propellor.EnsureProperty
 	) where
 
 import Propellor.Types
+import Propellor.Types.Core
 import Propellor.Types.MetaTypes
 import Propellor.Exception
 
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index ff0b3b5e..b87369c3 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -1,9 +1,11 @@
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}
 
 module Propellor.Info (
 	osDebian,
 	osBuntish,
 	osFreeBSD,
+	setInfoProperty,
+	addInfoProperty,
 	pureInfoProperty,
 	pureInfoProperty',
 	askInfo,
@@ -22,6 +24,7 @@ module Propellor.Info (
 
 import Propellor.Types
 import Propellor.Types.Info
+import Propellor.Types.MetaTypes
 
 import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
@@ -31,11 +34,32 @@ import Data.Monoid
 import Control.Applicative
 import Prelude
 
+-- | Adds info to a Property.
+--
+-- The new Property will include HasInfo in its metatypes.
+setInfoProperty
+	:: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
+	=> Property metatypes
+	-> Info
+	-> Property (MetaTypes metatypes')
+setInfoProperty (Property _ d a oldi c) newi =
+	Property sing d a (oldi <> newi) c
+
+-- | Adds more info to a Property that already HasInfo.
+addInfoProperty
+	:: (IncludesInfo metatypes ~ 'True)
+	=> Property metatypes
+	-> Info
+	-> Property metatypes
+addInfoProperty (Property t d a oldi c) newi =
+	Property t d a (oldi <> newi) c
+
+-- | Makes a property that does nothing but set some `Info`.
 pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)
 pureInfoProperty desc v = pureInfoProperty' desc (toInfo v)
 
 pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
-pureInfoProperty' desc i = addInfoProperty p i
+pureInfoProperty' desc i = setInfoProperty p i
   where
 	p :: Property UnixLike
 	p = property ("has " ++ desc) (return NoChange)
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 0bc0c100..d3bb3a6d 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -127,7 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 			"Fix this by running:" :
 			showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist)
 		return FailedChange
-	addinfo p = p `addInfoProperty'` (toInfo privset)
+	addinfo p = p `addInfoProperty` (toInfo privset)
 	privset = PrivInfo $ S.fromList $
 		map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
 	fieldnames = map show fieldlist
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 856f2e8e..d9fa8ec7 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -16,6 +16,7 @@ module Propellor.PropAccum
 
 import Propellor.Types
 import Propellor.Types.MetaTypes
+import Propellor.Types.Core
 import Propellor.Property
 
 import Data.Monoid
@@ -30,10 +31,6 @@ import Prelude
 host :: HostName -> Props metatypes -> Host
 host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
 
--- | Props is a combination of a list of properties, with their combined 
--- metatypes.
-data Props metatypes = Props [ChildProperty]
-
 -- | Start accumulating a list of properties.
 --
 -- Properties can be added to it using `(&)` etc.
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 70583edc..29a8ec0f 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -53,6 +53,7 @@ import Control.Applicative
 import Prelude
 
 import Propellor.Types
+import Propellor.Types.Core
 import Propellor.Types.ResultCheck
 import Propellor.Types.MetaTypes
 import Propellor.Info
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 811b5baa..09047ce5 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -23,6 +23,7 @@ import Propellor.Container
 import Propellor.Types.CmdLine
 import Propellor.Types.Chroot
 import Propellor.Types.Info
+import Propellor.Types.Core
 import Propellor.Property.Chroot.Util
 import qualified Propellor.Property.Debootstrap as Debootstrap
 import qualified Propellor.Property.Systemd.Core as Systemd
@@ -151,7 +152,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
 
 propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
 propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
-	p `addInfoProperty` chrootInfo c
+	p `setInfoProperty` chrootInfo c
 
 chrootInfo :: Chroot -> Info
 chrootInfo (Chroot loc _ h) = mempty `addInfo`
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index ace85a3c..e69dc17d 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -37,6 +37,8 @@ module Propellor.Property.Concurrent (
 ) where
 
 import Propellor.Base
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
 
 import Control.Concurrent
 import qualified Control.Concurrent.Async as A
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index ab747acc..8aa18d20 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -83,16 +83,17 @@ import qualified Propellor.Property.Ssh as Ssh
 import qualified Data.Set as S
 
 -- | Class of things that can be conducted.
+--
+-- There are instances for single hosts, and for lists of hosts.
+-- With a list, each listed host will be conducted in turn. Failure to conduct
+-- one host does not prevent conducting subsequent hosts in the list, but
+-- will be propagated as an overall failure of the property.
 class Conductable c where
 	conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
 
 instance Conductable Host where
-	-- | Conduct the specified host.
 	conducts h = conductorFor h <!> notConductorFor h
 
--- | Each host in the list will be conducted in turn. Failure to conduct
--- one host does not prevent conducting subsequent hosts in the list, but
--- will be propagated as an overall failure of the property.
 instance Conductable [Host] where
 	conducts hs = 
 		propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs)
@@ -246,7 +247,7 @@ orchestrate' h (Conductor c l)
 -- to have any effect.
 conductorFor :: Host -> Property (HasInfo + UnixLike)
 conductorFor h = go
-	`addInfoProperty` (toInfo (ConductorFor [h]))
+	`setInfoProperty` (toInfo (ConductorFor [h]))
 	`requires` setupRevertableProperty (conductorKnownHost h)
 	`requires` Ssh.installed
   where
@@ -270,7 +271,7 @@ conductorFor h = go
 -- Reverts conductorFor.
 notConductorFor :: Host -> Property (HasInfo + UnixLike)
 notConductorFor h = (doNothing :: Property UnixLike)
-	`addInfoProperty` (toInfo (NotConductorFor [h]))
+	`setInfoProperty` (toInfo (NotConductorFor [h]))
 	`describe` desc
 	`requires` undoRevertableProperty (conductorKnownHost h)
   where
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 2b5596bd..2e2710a6 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -81,7 +81,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 
 	(partialzone, zonewarnings) = genZone indomain hostmap domain soa
 	baseprop = primaryprop
-		`addInfoProperty` (toInfo (addNamedConf conf))
+		`setInfoProperty` (toInfo (addNamedConf conf))
 	primaryprop :: Property DebianLike
 	primaryprop = property ("dns primary for " ++ domain) $ do
 		sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index ddefef15..2ef97438 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -48,6 +48,7 @@ module Propellor.Property.Docker (
 import Propellor.Base hiding (init)
 import Propellor.Types.Docker
 import Propellor.Types.Container
+import Propellor.Types.Core
 import Propellor.Types.CmdLine
 import Propellor.Types.Info
 import Propellor.Container
@@ -183,7 +184,7 @@ imagePulled ctr = pulled `describe` msg
 
 propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
 propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
-	p `addInfoProperty'` dockerinfo
+	p `addInfoProperty` dockerinfo
   where
 	dockerinfo = dockerInfo $
 		mempty { _dockerContainers = M.singleton cn h }
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 6c775b94..704c1db9 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -51,7 +51,7 @@ update =
 		go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
 	in
 		(property "pkg update has run" go :: Property FreeBSD)
-			`addInfoProperty` (toInfo (PkgUpdate ""))
+			`setInfoProperty` (toInfo (PkgUpdate ""))
 
 newtype PkgUpgrade = PkgUpgrade String
 	deriving (Typeable, Monoid, Show)
@@ -68,7 +68,7 @@ upgrade =
 		go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
 	in
 		(property "pkg upgrade has run" go :: Property FreeBSD)
-			`addInfoProperty` (toInfo (PkgUpdate ""))
+			`setInfoProperty` (toInfo (PkgUpdate ""))
 			`requires` update
 
 type Package = String
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index a8b8347a..0eec04c7 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -13,6 +13,8 @@ module Propellor.Property.List (
 ) where
 
 import Propellor.Types
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
 import Propellor.PropAccum
 import Propellor.Engine
 import Propellor.Exception
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 291d4168..2bf5b927 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -3,6 +3,7 @@
 module Propellor.Property.Partition where
 
 import Propellor.Base
+import Propellor.Types.Core
 import qualified Propellor.Property.Apt as Apt
 import Utility.Applicative
 
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index 95e4e362..729a3749 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -10,6 +10,7 @@ module Propellor.Property.Scheduled
 	) where
 
 import Propellor.Base
+import Propellor.Types.Core
 import Utility.Scheduled
 
 import Data.Time.Clock
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index d5959cbb..6d6b14ea 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -8,15 +7,18 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 
-module Propellor.Types
-	( Host(..)
+module Propellor.Types (
+	-- * Core data types
+	  Host(..)
 	, Property(..)
 	, property
-	, Info
 	, Desc
-	, MetaType(..)
-	, MetaTypes
-	, TargetOS(..)
+	, RevertableProperty(..)
+	, (<!>)
+	, Propellor(..)
+	, LiftPropellor(..)
+	, Info
+	-- * Types of properties
 	, UnixLike
 	, Linux
 	, DebianLike
@@ -25,34 +27,22 @@ module Propellor.Types
 	, FreeBSD
 	, HasInfo
 	, type (+)
-	, addInfoProperty
-	, addInfoProperty'
-	, adjustPropertySatisfy
-	, RevertableProperty(..)
-	, (<!>)
-	, ChildProperty
-	, IsProp(..)
+	, TightenTargets(..)
+	-- * Combining and modifying properties
 	, Combines(..)
 	, CombinedType
 	, ResultCombiner
-	, Propellor(..)
-	, LiftPropellor(..)
-	, EndAction(..)
+	, adjustPropertySatisfy
+	-- * Other included types
 	, module Propellor.Types.OS
 	, module Propellor.Types.Dns
 	, module Propellor.Types.Result
 	, module Propellor.Types.ZFS
-	, TightenTargets(..)
-	, SingI
 	) where
 
 import Data.Monoid
-import "mtl" Control.Monad.RWS.Strict
-import Control.Monad.Catch
-import Data.Typeable
-import Control.Applicative
-import Prelude
 
+import Propellor.Types.Core
 import Propellor.Types.Info
 import Propellor.Types.OS
 import Propellor.Types.Dns
@@ -60,89 +50,38 @@ import Propellor.Types.Result
 import Propellor.Types.MetaTypes
 import Propellor.Types.ZFS
 
--- | Everything Propellor knows about a system: Its hostname,
--- properties and their collected info.
-data Host = Host
-	{ hostName :: HostName
-	, hostProperties :: [ChildProperty]
-	, hostInfo :: Info
-	}
-	deriving (Show, Typeable)
-
--- | Propellor's monad provides read-only access to info about the host
--- it's running on, and a writer to accumulate EndActions.
-newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
-	deriving
-		( Monad
-		, Functor
-		, Applicative
-		, MonadReader Host
-		, MonadWriter [EndAction]
-		, MonadIO
-		, MonadCatch
-		, MonadThrow
-		, MonadMask
-		)
-
-class LiftPropellor m where
-	liftPropellor :: m a -> Propellor a
-
-instance LiftPropellor Propellor where
-	liftPropellor = id
-
-instance LiftPropellor IO where
-	liftPropellor = liftIO
-
-instance Monoid (Propellor Result) where
-	mempty = return NoChange
-	-- | The second action is only run if the first action does not fail.
-	mappend x y = do
-		rx <- x
-		case rx of
-			FailedChange -> return FailedChange
-			_ -> do
-				ry <- y
-				return (rx <> ry)
-
--- | An action that Propellor runs at the end, after trying to satisfy all
--- properties. It's passed the combined Result of the entire Propellor run.
-data EndAction = EndAction Desc (Result -> Propellor Result)
-
-type Desc = String
-
 -- | The core data type of Propellor, this represents a property
--- that the system should have, with a descrition, an action to ensure
--- it has the property, and perhaps some Info that can be added to Hosts
+-- that the system should have, with a descrition, and an action to ensure
+-- it has the property.
 -- that have the property.
 --
--- A property has a list of `[MetaType]`, which is part of its type.
+-- There are different types of properties that target different OS's,
+-- and so have different metatypes. 
+-- For example: "Property DebianLike" and "Property FreeBSD".
 --
--- There are many instances and type families, which are mostly used
+-- Also, some properties have associated `Info`, which is indicated in
+-- their type: "Property (HasInfo + DebianLike)"
+--
+-- There are many associated type families, which are mostly used
 -- 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 = getDesc
-
 -- | Constructs a Property, from a description and an action to run to
 -- ensure the Property is met.
 --
--- You can specify any metatypes that make sense to indicate what OS
--- the property targets, etc.
+-- Due to the polymorphic return type of this function, most uses will need
+-- to specify a type signature. This lets you specify what OS the property
+-- targets, etc.
 --
 -- For example:
 --
 -- > foo :: Property Debian
--- > foo = mkProperty "foo" (...)
---
--- Note that using this needs LANGUAGE PolyKinds.
+-- > foo = property "foo" $ do
+-- >	...
+-- > 	return MadeChange
 property
 	:: SingI metatypes
 	=> Desc
@@ -150,26 +89,6 @@ property
 	-> Property (MetaTypes metatypes)
 property d a = Property sing d a mempty mempty
 
--- | Adds info to a Property.
---
--- The new Property will include HasInfo in its metatypes.
-addInfoProperty
-	:: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
-	=> Property metatypes
-	-> Info
-	-> Property (MetaTypes metatypes')
-addInfoProperty (Property _ d a oldi c) newi =
-	Property sing d a (oldi <> newi) c
-
--- | Adds more info to a Property that already HasInfo.
-addInfoProperty'
-	:: (IncludesInfo metatypes ~ 'True)
-	=> Property metatypes
-	-> Info
-	-> Property metatypes
-addInfoProperty' (Property t d a oldi c) newi =
-	Property t d a (oldi <> newi) c
-
 -- | 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
@@ -191,24 +110,6 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where
 	-> RevertableProperty setupmetatypes undometatypes
 setup <!> undo = RevertableProperty setup undo
 
-class IsProp p where
-	setDesc :: p -> Desc -> p
-	getDesc :: p -> Desc
-	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
-	-- | 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 (Property _ d _ _ _) = d
@@ -220,17 +121,6 @@ instance IsProp (Property metatypes) where
 	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
-	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
-
 instance IsProp (RevertableProperty setupmetatypes undometatypes) where
 	-- | Sets the description of both sides.
 	setDesc (RevertableProperty p1 p2) d =
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
new file mode 100644
index 00000000..fa939d2b
--- /dev/null
+++ b/src/Propellor/Types/Core.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Types.Core where
+
+import Propellor.Types.Info
+import Propellor.Types.OS
+import Propellor.Types.Result
+
+import Data.Monoid
+import "mtl" Control.Monad.RWS.Strict
+import Control.Monad.Catch
+import Control.Applicative
+import Prelude
+
+-- | Everything Propellor knows about a system: Its hostname,
+-- properties and their collected info.
+data Host = Host
+	{ hostName :: HostName
+	, hostProperties :: [ChildProperty]
+	, hostInfo :: Info
+	}
+	deriving (Show, Typeable)
+
+-- | Propellor's monad provides read-only access to info about the host
+-- it's running on, and a writer to accumulate EndActions.
+newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
+	deriving
+		( Monad
+		, Functor
+		, Applicative
+		, MonadReader Host
+		, MonadWriter [EndAction]
+		, MonadIO
+		, MonadCatch
+		, MonadThrow
+		, MonadMask
+		)
+
+class LiftPropellor m where
+	liftPropellor :: m a -> Propellor a
+
+instance LiftPropellor Propellor where
+	liftPropellor = id
+
+instance LiftPropellor IO where
+	liftPropellor = liftIO
+
+instance Monoid (Propellor Result) where
+	mempty = return NoChange
+	-- | The second action is only run if the first action does not fail.
+	mappend x y = do
+		rx <- x
+		case rx of
+			FailedChange -> return FailedChange
+			_ -> do
+				ry <- y
+				return (rx <> ry)
+
+-- | An action that Propellor runs at the end, after trying to satisfy all
+-- properties. It's passed the combined Result of the entire Propellor run.
+data EndAction = EndAction Desc (Result -> Propellor Result)
+
+type Desc = String
+
+-- | Props is a combination of a list of properties, with their combined 
+-- metatypes.
+data Props metatypes = Props [ChildProperty]
+
+-- | 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 = getDesc
+
+class IsProp p where
+	setDesc :: p -> Desc -> p
+	getDesc :: p -> Desc
+	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
+	-- | 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 ChildProperty where
+	setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
+	getDesc (ChildProperty d _ _ _) = d
+	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
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index c7f6b82f..2e188ae5 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -19,6 +19,9 @@ import Data.Monoid
 import Prelude
 
 -- | Information about a Host, which can be provided by its properties.
+--
+-- Many different types of data can be contained in the same Info value
+-- at the same time. See `toInfo` and `fromInfo`.
 newtype Info = Info [InfoEntry]
 	deriving (Monoid, Show)
 
@@ -47,6 +50,8 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where
 addInfo :: IsInfo v => Info -> v -> Info
 addInfo (Info l) v = Info (InfoEntry v:l)
 
+-- | Converts any value in the `IsInfo` type class into an Info,
+-- which is otherwise empty.
 toInfo :: IsInfo v => v -> Info
 toInfo = addInfo mempty
 
-- 
cgit v1.3-2-g0d8e