Merge branch 'joeyconfig'

8 files changed, 65 insertions, 54 deletions

diff --git a/config-joey.hs b/config-joey.hs
index b5982161..e973d35e 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -27,6 +27,7 @@ import qualified Propellor.Property.Journald as Journald
 import qualified Propellor.Property.Chroot as Chroot
 import qualified Propellor.Property.Aiccu as Aiccu
 import qualified Propellor.Property.OS as OS
+import qualified Propellor.Property.Spin as Spin
 import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
 import qualified Propellor.Property.HostingProvider.Linode as Linode
 import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
diff --git a/config-simple.hs b/config-simple.hs
index 0bc08def..21accd18 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -37,7 +37,6 @@ mybox = host "mybox.example.com"
 	& Docker.docked webserverContainer
 	& Docker.garbageCollected `period` Daily
 	& Cron.runPropellor (Cron.Times "30 * * * *")
-	]
 
 -- A generic webserver in a Docker container.
 webserverContainer :: Docker.Container
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 1225f411..e0830693 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -119,14 +119,11 @@ defaultMain hostlist = do
 	go True cmdline = updateFirst cmdline $ go False cmdline
 	go False (Spin hs r) = do
 		commitSpin
-		forM_ hs $ \hn -> withhost hn $
-			spin hn r mempty
+		forM_ hs $ \hn -> withhost hn $ spin hn r
 	go False cmdline@(SimpleRun hn) = buildFirst cmdline $
 		go False (Run hn)
-	go False cmdline@(ControlledRun hn cc) = buildFirst cmdline $
-		onlyprocess $ withhost hn $ mainProperties cc
 	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( onlyprocess $ withhost hn $ mainProperties mempty
+		( onlyprocess $ withhost hn mainProperties
 		, go True (Spin [hn] Nothing)
 		)
 
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 021ddd2c..8c1d09c6 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -27,8 +27,6 @@ import Propellor.Types
 import Propellor.Message
 import Propellor.Exception
 import Propellor.Info
-import Propellor.Types.Info
-import Propellor.Types.CmdLine
 import Propellor.Property
 import Utility.Exception
 import Utility.PartialPrelude
@@ -36,9 +34,9 @@ import Utility.Monad
 
 -- | Gets the Properties of a Host, and ensures them all,
 -- with nice display of what's being done.
-mainProperties :: ControllerChain -> Host -> IO ()
-mainProperties cc host = do
-	ret <- runPropellor host' $
+mainProperties :: Host -> IO ()
+mainProperties host = do
+	ret <- runPropellor host $
 		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
 	h <- mkMessageHandle
         whenConsole h $
@@ -48,8 +46,7 @@ mainProperties cc host = do
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
   where
-	ps = map ignoreInfo $ hostProperties host'
-	host' = addHostInfo host (InfoVal cc)
+	ps = map ignoreInfo $ hostProperties host
 
 -- | Runs a Propellor action with the specified host.
 --
diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs
index a08352d3..ee65b0a9 100644
--- a/src/Propellor/Property/Spin.hs
+++ b/src/Propellor/Property/Spin.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 
 module Propellor.Property.Spin (
 	Spinnable(..),
@@ -9,23 +9,31 @@ module Propellor.Property.Spin (
 
 import Propellor.Base
 import Propellor.Spin (spin)
-import Propellor.Types.CmdLine (ControllerChain(..))
 import Propellor.Types.Info
 import qualified Propellor.Property.Ssh as Ssh
 
+import qualified Data.Set as S
+
 -- | A class of things that can be spinned.
 class Spinnable t where
-	toSpin :: t -> Property NoInfo
+	toSpin :: t -> Property HasInfo
 
 instance Spinnable Host where
-	toSpin h = go `requires` Ssh.knownHost [h] (hostName h) (User "root")
+	toSpin h = infoProperty desc go (mkControllingInfo h) []
+		`requires` Ssh.knownHost [h] (hostName h) (User "root")
 	  where
-	  	go = property (cdesc (hostName h)) $ do
-			ControllerChain cc <- getControllerChain
-			if hostName h `elem` cc
-				then noChange -- avoid loop
+		desc = cdesc (hostName h)
+		go = do
+			thishost <- ask
+			if isControllerLoop thishost h
+				then errorMessage $ unwords
+					[ "controller loop detected involving"
+					, hostName thishost
+					, "and"
+					, hostName h
+					]
 				else do
-					liftIO $ spin (hostName h) Nothing (ControllerChain cc) h
+					liftIO $ spin (hostName h) Nothing h
 					-- Don't know if the spin made a change to the
 					-- remote host or not, but in any case, the
 					-- local host was not changed.
@@ -67,20 +75,20 @@ instance Spinnable [Host] where
 -- >	] ++ webservers
 -- > 
 -- > dnsserver = host "dns.example.com"
--- >	& Ssh.hostKeys hostContext [(SshEcdsa, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")]
+-- >	& Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")]
 -- >    & Spin.controlledBy master
 -- >	& ...
 -- > 
 -- > webservers =
 -- >    [ host "www1.example.com"
--- >		& Ssh.hostKeys hostContext [(SshEcdsa, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")]
+-- >		& Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")]
 -- > 		& Spin.controlledBy master
 -- >		& ...
 -- >	, ...
 -- >	]
 -- >
 -- > master = host "master.example.com"
--- >	& Spin.controllerKeys [(SshEcdsa, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")]
+-- >	& Spin.controllerKeys [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")]
 -- > 	-- Only update dnsserver once all webservers are successfully updated.
 -- >	& Spin.controllerFor dnsserver
 -- >		`requires` Spin.controllerFor webservers
@@ -93,12 +101,14 @@ instance Spinnable [Host] where
 --
 -- Chains of controllers are supported; host A can control host B which
 -- controls host C. Loops of controllers are automatically prevented.
-controllerFor :: Spinnable h => h -> Property NoInfo
+controllerFor :: Spinnable h => h -> Property HasInfo
 controllerFor h = toSpin h
 	`requires` Ssh.installed
 
 -- | Uses `Propellor.Property.Ssh.keysImported` to set up the ssh keys
--- for a controller; so the corresponding private keys come from the privdata.
+-- for the root user on a controller. 
+--
+-- (The corresponding private keys come from the privdata.)
 controllerKeys :: [(SshKeyType, Ssh.PubKeyText)] -> Property HasInfo
 controllerKeys ks = Ssh.userKeys (User "root") hostContext ks
 	`requires` Ssh.installed
@@ -112,10 +122,30 @@ controlledBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h)
 cdesc :: String -> Desc
 cdesc n = "controller for " ++ n
 
--- | The current host is included on the chain, as well as any hosts that
--- acted as controllers to get the current propellor process to run.
-getControllerChain :: Propellor ControllerChain
-getControllerChain = do
-	hn <- hostName <$> ask
-	ControllerChain cc <- fromMaybe (ControllerChain []) . fromInfoVal <$> askInfo
-	return (ControllerChain (hn:cc))
+-- To detect loops of controlled hosts, each Host's info contains a list
+-- of the hosts it's controlling.
+newtype Controlling = Controlled [Host]
+	deriving (Typeable, Monoid)
+
+isControlledBy :: Host -> Controlling -> Bool
+h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs)
+
+instance IsInfo Controlling where
+	propigateInfo _ = True
+
+mkControllingInfo :: Host -> Info
+mkControllingInfo controlled = addInfo mempty (Controlled [controlled])
+
+getControlledBy :: Host -> Controlling
+getControlledBy = getInfo . hostInfo
+
+isControllerLoop :: Host -> Host -> Bool
+isControllerLoop controller controlled = go S.empty controlled
+  where
+	go checked h
+		| controller `isControlledBy` c = True
+		-- avoid checking loops that have been checked before
+		| hostName h `S.member` checked = False
+		| otherwise = any (go (S.insert (hostName h) checked)) l
+	  where
+		c@(Controlled l) = getControlledBy h
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 401c9375..ecefbf6e 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -40,8 +40,8 @@ commitSpin = do
 		void $ actionMessage "Push to central git repository" $
 			boolSystem "git" [Param "push"]
 
-spin :: HostName -> Maybe HostName -> ControllerChain -> Host -> IO ()
-spin target relay cc hst = do
+spin :: HostName -> Maybe HostName -> Host -> IO ()
+spin target relay hst = do
 	cacheparams <- if viarelay
 		then pure ["-A"]
 		else toCommand <$> sshCachingParams hn
@@ -89,9 +89,7 @@ spin target relay cc hst = do
 	runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd
 	cmd = if viarelay
 		then "--serialized " ++ shellEscape (show (Spin [target] (Just target)))
-		else if cc == mempty
-			then "--continue " ++ shellEscape (show (SimpleRun target))
-			else "--continue " ++ shellEscape (show (ControlledRun target cc))
+		else "--continue " ++ shellEscape (show (SimpleRun target))
 
 -- Check if the Host contains an IP address that matches one of the IPs
 -- in the DNS for the HostName. If so, the HostName is used as-is, 
diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs
index ca73c902..558c6e8b 100644
--- a/src/Propellor/Types/CmdLine.hs
+++ b/src/Propellor/Types/CmdLine.hs
@@ -1,20 +1,15 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-
 module Propellor.Types.CmdLine where
 
 import Propellor.Types.OS
 import Propellor.Types.PrivData
 
 import System.Posix.Types
-import Data.Typeable
-import Data.Monoid
 
 -- | All the command line actions that propellor can perform.
 data CmdLine
 	= Run HostName
 	| Spin [HostName] (Maybe HostName)
 	| SimpleRun HostName
-	| ControlledRun HostName ControllerChain
 	| Set PrivDataField Context
 	| Unset PrivDataField Context
 	| UnsetUnused
@@ -34,7 +29,3 @@ data CmdLine
 	| GitPush Fd Fd
 	| Check
 	deriving (Read, Show, Eq)
-
--- | List of hosts that acted as controllers to cause a host to be spinned.
-newtype ControllerChain = ControllerChain [HostName]
-	deriving (Read, Show, Eq, Typeable, Monoid)
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index 347a03e7..3330a033 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 
 module Propellor.Types.Info (
 	Info,
@@ -17,15 +17,12 @@ import Data.Monoid
 import Data.Maybe
 
 -- | Information about a Host, which can be provided by its properties.
-data Info = Info [(Dynamic, Bool)]
+newtype Info = Info [(Dynamic, Bool)]
+	deriving (Monoid)
 
 instance Show Info where
 	show (Info l) = "Info " ++ show (map (dynTypeRep . fst) l)
 
-instance Monoid Info where
- 	mempty = Info []
-	mappend (Info a) (Info b) = Info (a <> b)
-
 -- | Values stored in Info must be members of this class.
 --
 -- This is used to avoid accidentially using other data types
@@ -40,6 +37,7 @@ class (Typeable v, Monoid v) => IsInfo v where
 addInfo :: IsInfo v => Info -> v -> Info
 addInfo (Info l) v = Info ((toDyn v, propigateInfo v):l)
 
+-- The list is reversed here because addInfo builds it up in reverse order.
 getInfo :: IsInfo v => Info -> v
 getInfo (Info l) = mconcat (mapMaybe (fromDynamic . fst) (reverse l))