From 4e9b01a8a7005905ecec37d1cd6a11d3b27676b7 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 8 Dec 2014 01:06:19 -0400
Subject: [PATCH] propellor spin

(cherry picked from commit 1d02d589c79781cc4b0bd82467edbdf64c40f34d)
---
 src/Propellor/Property.hs          | 6 ------
 src/Propellor/Property/Cmd.hs      | 6 +-----
 src/Propellor/Property/Docker.hs   | 9 +++++----
 src/Propellor/Property/Firewall.hs | 3 +--
 src/Propellor/Types.hs             | 8 ++++++++
 5 files changed, 15 insertions(+), 17 deletions(-)

diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 6371cc0..37fd90d 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -121,12 +121,6 @@ doNothing = property "noop property" noChange
 withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
 withOS desc a = property desc $ a =<< getOS
 
-boolProperty :: Desc -> IO Bool -> Property
-boolProperty desc a = property desc $ ifM (liftIO a)
-	( return MadeChange
-	, return FailedChange
-	)
-
 -- | Undoes the effect of a property.
 revert :: RevertableProperty -> RevertableProperty
 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 725f575..d24b1a8 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -13,7 +13,6 @@ import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Propellor.Property
-import Utility.Monad
 import Utility.SafeCommand
 import Utility.Env
 
@@ -28,10 +27,7 @@ cmdProperty cmd params = cmdProperty' cmd params []
 cmdProperty' :: String -> [String] -> [(String, String)] -> Property
 cmdProperty' cmd params env = property desc $ liftIO $ do
 	env' <- addEntries env <$> getEnvironment
-	ifM (boolSystemEnv cmd (map Param params) (Just env'))
-		( return MadeChange
-		, return FailedChange
-		)
+	toResult <$> boolSystemEnv cmd (map Param params) (Just env')
   where
 	desc = unwords $ cmd : params
 
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 5fa0651..5006ed9 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -379,9 +379,10 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
 			createDirectoryIfMissing True (takeDirectory $ identFile cid)
 		shim <- liftIO $ Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
 		liftIO $ writeFile (identFile cid) (show ident)
-		ensureProperty $ boolProperty "run" $ runContainer img
-			(runps ++ ["-i", "-d", "-t"])
-			[shim, "--continue", show (DockerInit (fromContainerId cid))]
+		ensureProperty $ property "run" $ liftIO $
+			toResult <$> runContainer img
+				(runps ++ ["-i", "-d", "-t"])
+				[shim, "--continue", show (DockerInit (fromContainerId cid))]
 
 -- | Called when propellor is running inside a docker container.
 -- The string should be the container's ContainerId.
@@ -466,7 +467,7 @@ stoppedContainer :: ContainerId -> Property
 stoppedContainer cid = containerDesc cid $ property desc $ 
 	ifM (liftIO $ elem cid <$> listContainers RunningContainers)
 		( liftIO cleanup `after` ensureProperty 
-			(boolProperty desc $ stopContainer cid)
+			(property desc $ liftIO $ toResult <$> stopContainer cid)
 		, return NoChange
 		)
   where
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index b660207..3018f98 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -33,8 +33,7 @@ rule c t rs = property ("firewall rule: " <> show r) addIpTable
 		exist <- boolSystem "iptables" (chk args)
 		if exist
 			then return NoChange
-			else ifM (boolSystem "iptables" (add args))
-				( return MadeChange , return FailedChange)
+			else toResult <$> boolSystem "iptables" (add args)
 	add params = (Param "-A") : params
 	chk params = (Param "-C") : params
 
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 72e0e7a..63abd22 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -14,6 +14,7 @@ module Propellor.Types
 	, requires
 	, Desc
 	, Result(..)
+	, ToResult(..)
 	, ActionResult(..)
 	, CmdLine(..)
 	, PrivDataField(..)
@@ -131,6 +132,13 @@ instance Monoid Result where
 	mappend _ MadeChange = MadeChange
 	mappend NoChange NoChange = NoChange
 
+class ToResult t where
+	toResult :: t -> Result
+
+instance ToResult Bool where
+	toResult False = FailedChange
+	toResult True = MadeChange
+
 -- | Results of actions, with color.
 class ActionResult a where
 	getActionResult :: a -> (String, ColorIntensity, Color)