From 1edce2b72614e2e8eceefde97436db024799ff20 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 25 Mar 2016 15:28:31 -0400
Subject: ported Property.Apt

---
 src/Propellor/Property/Apt.hs | 113 ++++++++++++++++++++++--------------------
 1 file changed, 58 insertions(+), 55 deletions(-)

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

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


From e28f49b7d1ae361e42809977bf12d3f126c3d90d Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 25 Mar 2016 15:32:16 -0400
Subject: much simpler and more type safe implementation of Apt.robustly, using
 fallback!

---
 src/Propellor/Property/Apt.hs | 10 ++--------
 1 file changed, 2 insertions(+), 8 deletions(-)

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

diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 3dd7277e..9c3b05c4 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -75,7 +75,7 @@ securityUpdates suite
 		in [l, srcLine l]
 	| otherwise = []
 
--- | Makes sources.list have a standard content using the mirror CDN,
+-- | Makes sources.list have a standard content using the Debian mirror CDN,
 -- with the Debian suite configured by the os.
 --
 -- Since the CDN is sometimes unreliable, also adds backup lines using
@@ -196,13 +196,7 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
 -- | Package installation may fail becuse the archive has changed.
 -- Run an update in that case and retry.
 robustly :: Property DebianLike -> Property DebianLike
-robustly p = adjustPropertySatisfy p $ \satisfy -> do
-	r <- satisfy
-	if r == FailedChange
-		-- Safe to use getSatisfy because we're re-running
-		-- the same property as before.
-		then getSatisfy $ p `requires` update
-		else return r
+robustly p = p `fallback` (update `before` p)
 
 isInstallable :: [Package] -> IO Bool
 isInstallable ps = do
-- 
cgit v1.3-2-g0d8e


From 860d1dd77e1789a91ed61bdceab667d94c9bd345 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 25 Mar 2016 17:36:52 -0400
Subject: cleanup warnings

---
 src/Propellor/EnsureProperty.hs  | 24 ++++++++++++------------
 src/Propellor/Property.hs        | 14 +++++++-------
 src/Propellor/Property/Apt.hs    | 14 +++++++-------
 src/Propellor/Types/MetaTypes.hs |  4 ++--
 4 files changed, 28 insertions(+), 28 deletions(-)

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

diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index c4b5fde1..c19dc025 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -7,7 +7,7 @@
 module Propellor.EnsureProperty
 	( ensureProperty
 	, property'
-	, OuterMetaTypes(..)
+	, OuterMetaTypesWitness(..)
 	) where
 
 import Propellor.Types
@@ -17,14 +17,14 @@ import Propellor.Exception
 -- | For when code running in the Propellor monad needs to ensure a
 -- Property.
 --
--- Use `property'` to get the `OuterMetaTypes`. For example:
+-- Use `property'` to get the `OuterMetaTypesWithness`. For example:
 --
 -- > foo = Property Debian
--- > foo = property' $ \o -> do
--- > 	ensureProperty o (aptInstall "foo")
+-- > foo = property' $ \w -> do
+-- > 	ensureProperty w (aptInstall "foo")
 --
 -- The type checker will prevent using ensureProperty with a property
--- that does not support the target OSes needed by the OuterMetaTypes.
+-- that does not support the target OSes needed by the OuterMetaTypesWitness.
 -- In the example above, aptInstall must support Debian, since foo
 -- is supposed to support Debian.
 --
@@ -36,7 +36,7 @@ ensureProperty
 		( Cannot_ensureProperty_WithInfo inner ~ 'True
 		, (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine
 		)
-	=> OuterMetaTypes outer
+	=> OuterMetaTypesWitness outer
 	-> Property (MetaTypes inner)
 	-> Propellor Result
 ensureProperty _ = catchPropellor . getSatisfy
@@ -48,19 +48,19 @@ type instance Cannot_ensureProperty_WithInfo (t ': ts) =
 	Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts
 
 -- | Constructs a property, like `property`, but provides its
--- `OuterMetaTypes`.
+-- `OuterMetaTypesWitness`.
 property'
 	:: SingI metatypes
 	=> Desc
-	-> (OuterMetaTypes metatypes -> Propellor Result)
+	-> (OuterMetaTypesWitness metatypes -> Propellor Result)
 	-> Property (MetaTypes metatypes)
 property' d a =
-	let p = Property sing d (a (outerMetaTypes p)) mempty mempty
+	let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty
 	in p
 
 -- | Used to provide the metatypes of a Property to calls to 
 -- 'ensureProperty` within it.
-newtype OuterMetaTypes metatypes = OuterMetaTypes (MetaTypes metatypes)
+newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes)
 
-outerMetaTypes :: Property (MetaTypes l) -> OuterMetaTypes l
-outerMetaTypes (Property metatypes _ _ _ _) = OuterMetaTypes metatypes
+outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l
+outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 2ddec439..9fa29888 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -22,7 +22,7 @@ module Propellor.Property (
 	, Propellor
 	, property
 	, property'
-	, OuterMetaTypes
+	, OuterMetaTypesWitness
 	, ensureProperty
 	, withOS
 	, unsupportedOS
@@ -270,9 +270,9 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io
 -- of the host's operating system.
 --
 -- > myproperty :: Property Debian
--- > myproperty = withOS "foo installed" $ \o os -> case os of
--- > 	(Just (System (Debian (Stable release)) arch)) -> ensureProperty o ...
--- > 	(Just (System (Debian suite) arch)) -> ensureProperty o ...
+-- > myproperty = withOS "foo installed" $ \w o -> case o of
+-- > 	(Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...
+-- > 	(Just (System (Debian suite) arch)) -> ensureProperty w ...
 -- >	_ -> unsupportedOS
 --
 -- Note that the operating system specifics may not be declared for all hosts,
@@ -280,15 +280,15 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io
 withOS
 	:: (SingI metatypes)
 	=> Desc
-	-> (OuterMetaTypes '[] -> Maybe System -> Propellor Result)
+	-> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result)
 	-> Property (MetaTypes metatypes)
 withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
   where
 	-- Using this dummy value allows ensureProperty to be used
 	-- even though the inner property probably doesn't target everything
 	-- that the outer withOS property targets.
-	dummyoutermetatypes :: OuterMetaTypes ('[])
-	dummyoutermetatypes = OuterMetaTypes sing
+	dummyoutermetatypes :: OuterMetaTypesWitness ('[])
+	dummyoutermetatypes = OuterMetaTypesWitness sing
 
 -- | Throws an error, for use in `withOS` when a property is lacking
 -- support for an OS.
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 9c3b05c4..c8ad92e4 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -81,9 +81,9 @@ securityUpdates suite
 -- Since the CDN is sometimes unreliable, also adds backup lines using
 -- kernel.org.
 stdSourcesList :: Property Debian
-stdSourcesList = withOS "standard sources.list" $ \o os -> case os of
+stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
 	(Just (System (Debian suite) _)) ->
-		ensureProperty o $ stdSourcesListFor suite
+		ensureProperty w $ stdSourcesListFor suite
 	_ -> unsupportedOS
 
 stdSourcesListFor :: DebianSuite -> Property Debian
@@ -158,10 +158,10 @@ installed' params ps = robustly $ check (isInstallable ps) go
 	go = runApt (params ++ ["install"] ++ ps)
 
 installedBackport :: [Package] -> Property DebianLike
-installedBackport ps = withOS desc $ \o os -> case os of
+installedBackport ps = withOS desc $ \w o -> case o of
 	(Just (System (Debian suite) _)) -> case backportSuite suite of
 		Nothing -> unsupportedOS
-		Just bs -> ensureProperty o $
+		Just bs -> ensureProperty w $
 			runApt (["install", "-t", bs, "-y"] ++ ps)
 				`changesFile` dpkgStatus
 	_ -> unsupportedOS
@@ -247,11 +247,11 @@ unattendedUpgrades = enable <!> disable
 			| otherwise = "false"
 
 	configure :: Property DebianLike
-	configure = withOS "unattended upgrades configured" $ \o os ->
-		case os of
+	configure = withOS "unattended upgrades configured" $ \w o ->
+		case o of
 			-- the package defaults to only upgrading stable
 			(Just (System (Debian suite) _))
-				| not (isStable suite) -> ensureProperty o $
+				| not (isStable suite) -> ensureProperty w $
 					"/etc/apt/apt.conf.d/50unattended-upgrades"
 						`File.containsLine`
 					("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index 6545c924..6033ec27 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -116,8 +116,8 @@ type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine
 -- one target, so can only happen if there's already been a type error.
 -- This special case lets the type checker show only the original type
 -- error, and not an extra error due to a later CheckCombinable constraint.
-type instance CheckCombinable '[] list2 = CanCombine
-type instance CheckCombinable list1 '[] = CanCombine
+type instance CheckCombinable '[] list2 = 'CanCombine
+type instance CheckCombinable list1 '[] = 'CanCombine
 type instance CheckCombinable (l1 ': list1) (l2 ': list2) =
 	CheckCombinable' (Combine (l1 ': list1) (l2 ': list2))
 type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine
-- 
cgit v1.3-2-g0d8e


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

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

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

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


From 5f41492d8afe6ac6ee3cc280c3e2f252bcc91817 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 28 Mar 2016 04:46:21 -0400
Subject: propellor spin

---
 src/Propellor/Property.hs             | 18 ++++++++----------
 src/Propellor/Property/Apt.hs         |  6 +++---
 src/Propellor/Property/Debootstrap.hs | 19 +++++--------------
 src/Propellor/Property/Grub.hs        |  2 +-
 src/Propellor/Property/OS.hs          |  2 +-
 src/Propellor/Property/Ssh.hs         |  2 +-
 6 files changed, 19 insertions(+), 30 deletions(-)

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

diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 7878912b..55c39ee2 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -28,6 +28,7 @@ module Propellor.Property (
 	, pickOS
 	, withOS
 	, unsupportedOS
+	, unsupportedOS'
 	, makeChange
 	, noChange
 	, doNothing
@@ -292,7 +293,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
 			then getSatisfy a
 			else if matching o b
 				then getSatisfy b
-				else unsupportedOS
+				else unsupportedOS'
 	matching Nothing _ = False
 	matching (Just o) p = 
 		Targeting (systemToTargetOS o)
@@ -307,7 +308,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
 -- > myproperty = withOS "foo installed" $ \w o -> case o of
 -- > 	(Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...
 -- > 	(Just (System (Debian suite) arch)) -> ensureProperty w ...
--- >	_ -> unsupportedOS
+-- >	_ -> unsupportedOS'
 --
 -- Note that the operating system specifics may not be declared for all hosts,
 -- which is where Nothing comes in.
@@ -324,21 +325,18 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
 	dummyoutermetatypes :: OuterMetaTypesWitness ('[])
 	dummyoutermetatypes = OuterMetaTypesWitness sing
 
-class UnsupportedOS a where
-	unsupportedOS :: a
+-- | A property that always fails with an unsupported OS error.
+unsupportedOS :: Property UnixLike
+unsupportedOS = property "unsupportedOS" unsupportedOS'
 
 -- | Throws an error, for use in `withOS` when a property is lacking
 -- support for an OS.
-instance UnsupportedOS (Propellor a) where
-	unsupportedOS = go =<< getOS
+unsupportedOS' :: Propellor Result
+unsupportedOS' = go =<< getOS
 	  where
 		go Nothing = error "Unknown host OS is not supported by this property."
 		go (Just o) = error $ "This property is not implemented for " ++ show o
 
--- | A property that always fails with an unsupported OS error.
-instance UnsupportedOS (Property UnixLike) where
-	unsupportedOS = property "unsupportedOS" unsupportedOS
-
 -- | Undoes the effect of a RevertableProperty.
 revert :: RevertableProperty setup undo -> RevertableProperty undo setup
 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 2199d950..1a15f72c 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -84,7 +84,7 @@ stdSourcesList :: Property Debian
 stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
 	(Just (System (Debian suite) _)) ->
 		ensureProperty w $ stdSourcesListFor suite
-	_ -> unsupportedOS
+	_ -> unsupportedOS'
 
 stdSourcesListFor :: DebianSuite -> Property Debian
 stdSourcesListFor suite = stdSourcesList' suite []
@@ -160,11 +160,11 @@ installed' params ps = robustly $ check (isInstallable ps) go
 installedBackport :: [Package] -> Property Debian
 installedBackport ps = withOS desc $ \w o -> case o of
 	(Just (System (Debian suite) _)) -> case backportSuite suite of
-		Nothing -> unsupportedOS
+		Nothing -> unsupportedOS'
 		Just bs -> ensureProperty w $
 			runApt (["install", "-t", bs, "-y"] ++ ps)
 				`changesFile` dpkgStatus
-	_ -> unsupportedOS
+	_ -> unsupportedOS'
   where
 	desc = unwords ("apt installed backport":ps)
 
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index fd5f6c96..e0c56966 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -101,21 +101,12 @@ extractSuite (System (FreeBSD _) _) = Nothing
 installed :: RevertableProperty Linux Linux
 installed = install <!> remove
   where
-	install = withOS "debootstrap installed" $ \w o ->
-		ifM (liftIO $ isJust <$> programPath)
-			( return NoChange
-			, ensureProperty w (installon o)
-			)
-
-	installon (Just (System (Debian _) _)) = aptinstall
-	installon (Just (System (Buntish _) _)) = aptinstall
-	installon _ = sourceInstall
+	install = check (isJust <$> programPath) $
+		(aptinstall `pickOS` sourceInstall)
+			`describe` "debootstrap installed"
 
-	remove = withOS "debootstrap removed" $ \w o -> 
-		ensureProperty w (removefrom o)
-	removefrom (Just (System (Debian _) _)) = aptremove
-	removefrom (Just (System (Buntish _) _)) = aptremove
-	removefrom _ = sourceRemove
+	remove = (aptremove `pickOS` sourceRemove)
+		`describe` "debootstrap removed"
 
 	aptinstall = Apt.installed ["debootstrap"]
 	aptremove = Apt.removed ["debootstrap"]
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 85d098ed..a03fc5a0 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -30,7 +30,7 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" []
 
 -- | Installs grub; does not run update-grub.
 installed' :: BIOS -> Property Linux
-installed' bios = (aptinstall `pickOS` aptinstall)
+installed' bios = (aptinstall `pickOS` unsupportedOS)
 	`describe` "grub package installed"
   where
 	aptinstall :: Property DebianLike
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index 72753248..7d0a10ca 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -89,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 			debootstrap d
 		(Just u@(System (Buntish _) _)) -> ensureProperty w $
 			debootstrap u
-		_ -> unsupportedOS
+		_ -> unsupportedOS'
 	
 	debootstrap :: System -> Property Linux
 	debootstrap targetos =
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 7048de3b..369999b7 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -53,7 +53,7 @@ installed = withOS "ssh installed" $ \w o ->
 	in case o of
 		(Just (System (Debian _) _)) -> aptinstall
 		(Just (System (Buntish _) _)) -> aptinstall
-		_ -> unsupportedOS
+		_ -> unsupportedOS'
 
 restarted :: Property DebianLike
 restarted = Service.restarted "ssh"
-- 
cgit v1.3-2-g0d8e