type-safe reversions

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 ]

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 &

Propellor/Property/Apt.hs

@@ -129,9 +129,11 @@ autoRemove :: Property
 autoRemove = runApt ["-y", "autoremove"]
 	`describe` "apt autoremove"
 
-unattendedUpgrades :: Bool -> Property
+-- | Enables unattended upgrades. Revert to disable.
-unattendedUpgrades enabled =
+unattendedUpgrades :: RevertableProperty
-	(if enabled then installed else removed) ["unattended-upgrades"]
+unattendedUpgrades = RevertableProperty (go True) (go False)
+  where
+	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)

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
+		let setup = provisionContainer cid
 				`requires`
 			runningContainer cid image containerprops
-  where
+		    teardown = 
-  	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
 					]
+		in RevertableProperty setup teardown
   where
   	cid = ContainerId hn cn
 
@@ -73,15 +67,16 @@ findContainer
 	:: (HostName -> ContainerName -> Maybe (Container))
 	-> HostName
 	-> ContainerName
-	-> (Container -> Property)
+	-> (Container -> RevertableProperty)
-	-> Property
+	-> RevertableProperty
 findContainer findc hn cn mk = case findc hn cn of
-	Nothing -> containerDesc (ContainerId hn cn) $ Property "" $ do
+	Nothing -> RevertableProperty cantfind cantfind
-		warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
-		return FailedChange
 	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

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)
+
+

TODO

@@ -6,9 +6,6 @@
 * --spin needs 4 ssh connections when bootstrapping a new host
   that does not have the git repo yet. Should be possible to get that
   down to 1.
-* Make a way to express that a Property can be reverted (ie, installing a
-  packages reverses to removing it). Then `reverted property` can be
-  used to disable old properties.
 * Currently only Debian and derivatives are supported by most Properties.
   One way to improve that would be to parameterize Properties with a
   Distribution witness.

config.hs

@@ -2,7 +2,7 @@
 -- the propellor program.
 --
 -- This is the live config file used by propellor's author.
--- For a simpler starting point, see config.hs.simple.
+-- For a simpler starting point, see simple-config.hs
 
 import Propellor
 import Propellor.CmdLine
@@ -31,33 +31,31 @@ main = defaultMain [host, Docker.containerProperties container]
 --
 -- Edit this to configure propellor!
 host :: HostName -> Maybe [Property]
-host hostname@"clam.kitenet.net" = Just
+host hostname@"clam.kitenet.net" = Just $ props
-	[ cleanCloudAtCost hostname
+	& cleanCloudAtCost hostname
-	, standardSystem Unstable
+	& standardSystem Unstable
-	, Apt.unattendedUpgrades True
+	& Apt.unattendedUpgrades
-	, Network.ipv6to4
+	& Network.ipv6to4
+	& Apt.installed ["git-annex", "mtr"]
 	-- Clam is a tor bridge, and an olduse.net shellbox and other
 	-- fun stuff.
-	, Tor.isBridge
+	& Tor.isBridge
-	, JoeySites.oldUseNetshellBox
+	& JoeySites.oldUseNetshellBox
-	, Docker.configured
+	& Docker.configured
-	, File.dirExists "/var/www"
+	& File.dirExists "/var/www"
-	--, Docker.docked container hostname "webserver"
+	& revert (Docker.docked container hostname "webserver")
-	, Docker.garbageCollected
+	& revert (Docker.docked container hostname "amd64-git-annex-builder")
-	, Docker.unDocked container hostname "amd64-git-annex-builder"
+	& Docker.garbageCollected
-	, Apt.installed ["git-annex", "mtr"]
 	-- Should come last as it reboots.
-	, Apt.installed ["systemd-sysv"] `onChange` Reboot.now
+	& Apt.installed ["systemd-sysv"] `onChange` Reboot.now
-	]
+host hostname@"orca.kitenet.net" = Just $ props
-host hostname@"orca.kitenet.net" = Just
+	& Hostname.set hostname
-	[ Hostname.set hostname
+	& standardSystem Unstable
-	, standardSystem Unstable
+	& Apt.unattendedUpgrades
-	, Apt.unattendedUpgrades True
+	& Docker.configured
-	, Docker.configured
+	& revert (Docker.docked container hostname "amd64-git-annex-builder")
-	, Docker.unDocked container hostname "amd64-git-annex-builder"
+	& revert (Docker.docked container hostname "i386-git-annex-builder")
-	, Docker.unDocked container hostname "i386-git-annex-builder"
+	& Docker.garbageCollected
-	, Docker.garbageCollected
-	]
 -- add more hosts here...
 --host "foo.example.com" =
 host _ = Nothing
@@ -70,16 +68,15 @@ container _host name
 		(image $ System (Debian Unstable) "amd64")
 		[ Docker.publish "8080:80"
 		, Docker.volume "/var/www:/var/www"
-		, Docker.inside
+		, Docker.inside $ props
-			[ serviceRunning "apache2"
+			& serviceRunning "apache2"
 				`requires` Apt.installed ["apache2"]
 		]
-		]
 	| "-git-annex-builder" `isSuffixOf` name =
 		let arch = takeWhile (/= '-') name
 		in Just $ Docker.containerFrom
 			(image $ System (Debian Unstable) arch)
-			[ Docker.inside [ GitAnnexBuilder.builder arch "15 * * * *" ] ]
+			[ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" ]
 	| otherwise = Nothing
 
 -- | Docker images I prefer to use.

debian/changelog

@@ -7,5 +7,10 @@ propellor (0.2) UNRELEASED; urgency=low
     to pull commits from git repositories not signed with that key.
     This allows propellor to be securely used with public, non-encrypted
     git repositories without the possibility of MITM.
+  * Added support for type-safe reversions. Only some properties can be
+    reverted; the type checker will tell you if you try something that won't
+    work.
+  * New syntactic sugar for building a list of properties, including
+    revertable properties.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 01 Apr 2014 15:05:00 -0400

propellor.cabal

@@ -17,7 +17,7 @@ Extra-Source-Files:
   Makefile
   debian/changelog
   debian/README
-  config.hs.simple
+  simple-config.hs
 Synopsis: property-based host configuration management in haskell
 Description:
  Propellor enures that the system it's run in satisfies a list of

simple-config.hs

@@ -23,19 +23,18 @@ main = defaultMain [host, Docker.containerProperties container]
 --
 -- Edit this to configure propellor!
 host :: HostName -> Maybe [Property]
-host hostname@"mybox.example.com" = Just
+host hostname@"mybox.example.com" = Just $ props
-	[ Apt.stdSourcesList Unstable
+	& Apt.stdSourcesList Unstable
 		`onChange` Apt.upgrade
-	, Apt.unattendedUpgrades True
+	& Apt.unattendedUpgrades
-	, Apt.installed ["etckeeper"]
+	& Apt.installed ["etckeeper"]
-	, Apt.installed ["ssh"]
+	& Apt.installed ["ssh"]
-	, User.hasSomePassword "root"
+	& User.hasSomePassword "root"
-	, Network.ipv6to4
+	& Network.ipv6to4
-	, Docker.docked container hostname "webserver"
+	& Docker.docked container hostname "webserver"
 		`requires` File.dirExists "/var/www"
-	, Docker.garbageCollected
+	& Docker.garbageCollected
-	, Cron.runPropellor "30 * * * *"
+	& Cron.runPropellor "30 * * * *"
-	]
 -- add more hosts here...
 --host "foo.example.com" =
 host _ = Nothing
@@ -44,12 +43,10 @@ host _ = Nothing
 -- can vary by hostname where it's used, or be the same everywhere.
 container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
 container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
-	(image $ System (Debian Unstable) "amd64")
 	[ Docker.publish "80:80"
 	, Docker.volume "/var/www:/var/www"
-	, Docker.inside
+	, Docker.inside $ props
-		[ serviceRunning "apache2"
+		& serviceRunning "apache2"
 			`requires` Apt.installed ["apache2"]
 	]
-	]
 container _ _ = Nothing