type-safe reversions

5 files changed, 77 insertions, 45 deletions

diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index c267e7d4..d1a758ab 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -245,14 +245,14 @@ fromMarked marker s
 	matches = filter (marker `isPrefixOf`) $ lines s
 
 boot :: [Property] -> IO ()
-boot props = do
+boot ps = do
 	sendMarked stdout statusMarker $ show Ready
 	reply <- hGetContentsStrict stdin
 
 	makePrivDataDir
 	maybe noop (writeFileProtected privDataLocal) $
 		fromMarked privDataMarker reply
-	ensureProperties props
+	ensureProperties ps
 
 addKey :: String -> IO ()
 addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index 2764d614..10a51530 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -58,14 +58,6 @@ property `onChange` hook = Property (propertyDesc property) $ do
 			return $ r <> r'
 		_ -> return r
 
--- | Indicates that the first property can only be satisfied once
--- the second is.
-requires :: Property -> Property -> Property
-x `requires` y = combineProperties (propertyDesc x) [y, x]
-
-describe :: Property -> Desc -> Property
-describe p d = p { propertyDesc = d }
-
 (==>) :: Desc -> Property -> Property
 (==>) = flip describe
 infixl 1 ==>
@@ -76,3 +68,17 @@ check c property = Property (propertyDesc property) $ ifM c
 	( ensureProperty property
 	, return NoChange
 	)
+
+-- | Undoes the effect of a property.
+revert :: RevertableProperty -> RevertableProperty
+revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
+
+-- | Starts a list of Properties
+props :: [Property]
+props = []
+
+-- | Adds a property to the list.
+-- Can add both Properties and RevertableProperties.
+(&) :: IsProp p => [Property] -> p -> [Property]
+ps & p = toProp p : ps
+infixl 1 &
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 92e23b7e..0b8b8ab9 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -129,16 +129,18 @@ autoRemove :: Property
 autoRemove = runApt ["-y", "autoremove"]
 	`describe` "apt autoremove"
 
-unattendedUpgrades :: Bool -> Property
-unattendedUpgrades enabled =
-	(if enabled then installed else removed) ["unattended-upgrades"]
-	`onChange` reConfigure "unattended-upgrades"
-		[("unattended-upgrades/enable_auto_updates" , "boolean", v)]
-	`describe` ("unattended upgrades " ++ v)
+-- | Enables unattended upgrades. Revert to disable.
+unattendedUpgrades :: RevertableProperty
+unattendedUpgrades = RevertableProperty (go True) (go False)
   where
-	v
-		| enabled = "true"
-		| otherwise = "false"
+	go enabled = (if enabled then installed else removed) ["unattended-upgrades"]
+		`onChange` reConfigure "unattended-upgrades"
+			[("unattended-upgrades/enable_auto_updates" , "boolean", v)]
+		`describe` ("unattended upgrades " ++ v)
+	  where
+		v
+			| enabled = "true"
+			| otherwise = "false"
 
 -- | Preseeds debconf values and reconfigures the package so it takes
 -- effect.
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index d8b1027c..3f90d157 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -39,33 +39,27 @@ installed = Apt.installed ["docker.io"]
 -- | Ensures that a docker container is set up and running. The container
 -- has its own Properties which are handled by running propellor
 -- inside the container.
+--
+-- Reverting this property ensures that the container is stopped and
+-- removed.
 docked
 	:: (HostName -> ContainerName -> Maybe (Container))
 	-> HostName
 	-> ContainerName
-	-> Property
+	-> RevertableProperty
 docked findc hn cn = findContainer findc hn cn $
 	\(Container image containerprops) ->
-		provisionContainer cid
-			`requires`
-		runningContainer cid image containerprops
-  where
-  	cid = ContainerId hn cn
-
--- | Ensures that a docker container is no longer running.
-unDocked
-	:: (HostName -> ContainerName -> Maybe (Container))
-	-> HostName
-	-> ContainerName
-	-> Property
-unDocked findc hn cn = findContainer findc hn cn $
-	\(Container image _containerprops) ->
-		Property ("undocked " ++ fromContainerId cid) $
-			report <$> mapM id
-				[ stopContainer cid
-				, removeContainer cid
-				, removeImage image
-				]
+		let setup = provisionContainer cid
+				`requires`
+			runningContainer cid image containerprops
+		    teardown = 
+			Property ("undocked " ++ fromContainerId cid) $
+				report <$> mapM id
+					[ stopContainer cid
+					, removeContainer cid
+					, removeImage image
+					]
+		in RevertableProperty setup teardown
   where
   	cid = ContainerId hn cn
 
@@ -73,15 +67,16 @@ findContainer
 	:: (HostName -> ContainerName -> Maybe (Container))
 	-> HostName
 	-> ContainerName
-	-> (Container -> Property)
-	-> Property
+	-> (Container -> RevertableProperty)
+	-> RevertableProperty
 findContainer findc hn cn mk = case findc hn cn of
-	Nothing -> containerDesc (ContainerId hn cn) $ Property "" $ do
-		warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
-		return FailedChange
+	Nothing -> RevertableProperty cantfind cantfind
 	Just container -> mk container
   where
   	cid = ContainerId hn cn
+	cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
+		warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
+		return FailedChange
 
 -- | Causes *any* docker images that are not in use by running containers to
 -- be deleted. And deletes any containers that propellor has set up
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 1be56748..52c0c999 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -12,6 +12,33 @@ data Property = Property
 	, propertySatisfy :: IO Result
 	}
 
+data RevertableProperty = RevertableProperty Property Property
+
+class IsProp p where
+	-- | Sets description.
+	describe :: p -> Desc -> p
+	toProp :: p -> Property
+	-- | Indicates that the first property can only be satisfied
+	-- once the second one is.
+	requires :: p -> Property -> p
+
+instance IsProp Property where
+	describe p d = p { propertyDesc = d }
+	toProp p = p
+	x `requires` y = Property (propertyDesc x) $ do
+		r <- propertySatisfy y
+		case r of
+			FailedChange -> return FailedChange
+			_ -> propertySatisfy x
+
+instance IsProp RevertableProperty where
+	-- | Sets the description of both sides.
+	describe (RevertableProperty p1 p2) d = 
+		RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
+	toProp (RevertableProperty p1 _) = p1
+	(RevertableProperty p1 p2) `requires` y =
+		RevertableProperty (p1 `requires` y) p2
+
 type Desc = String
 
 data Result = NoChange | MadeChange | FailedChange
@@ -74,3 +101,5 @@ data PrivDataField
 	| SshPrivKey UserName
 	| Password UserName
 	deriving (Read, Show, Ord, Eq)
+
+