summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-17 14:48:15 -0400
committerJoey Hess2015-10-17 14:48:15 -0400
commitf6e352767eaf236acb929a9793dee28eb4897baa (patch)
tree57189708f4142015de967938d4e098a2ea6e165e
parentfe052464493571ac26d825823c8c6e95ddb096e2 (diff)
parent57f4eca88a1c3762b452171ee0a9d1a4f1367402 (diff)
Merge branch 'joeyconfig'
-rw-r--r--config-joey.hs1
-rw-r--r--config-simple.hs1
-rw-r--r--src/Propellor/CmdLine.hs7
-rw-r--r--src/Propellor/Engine.hs11
-rw-r--r--src/Propellor/Property/Spin.hs72
-rw-r--r--src/Propellor/Spin.hs8
-rw-r--r--src/Propellor/Types/CmdLine.hs9
-rw-r--r--src/Propellor/Types/Info.hs10
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))