From 02269cc630fd8bf81423eb6c0d9d6442b0661847 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 16 Oct 2015 20:00:23 -0400 Subject: fix key types in examples --- src/Propellor/Property/Spin.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs index a08352d3..79485569 100644 --- a/src/Propellor/Property/Spin.hs +++ b/src/Propellor/Property/Spin.hs @@ -67,20 +67,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 -- cgit v1.2.3 From a487fd07dc72ba506b3d185c4d9317e5a443faa3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 17 Oct 2015 11:13:33 -0400 Subject: newtype info allows deriving monoid --- src/Propellor/Types/Info.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'src') 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)) -- cgit v1.2.3 From 4e038a43cc9978af1015c53ab7cf27355d989069 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 17 Oct 2015 13:57:51 -0400 Subject: use Info to detect controller loops Much less invasive than the other implementation. --- config-joey.hs | 2 ++ src/Propellor/CmdLine.hs | 7 ++--- src/Propellor/Engine.hs | 11 +++----- src/Propellor/Property/Spin.hs | 62 ++++++++++++++++++++++++++++++------------ src/Propellor/Spin.hs | 8 ++---- src/Propellor/Types/CmdLine.hs | 9 ------ 6 files changed, 56 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index b5982161..f862a2fb 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 @@ -189,6 +190,7 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf" kite :: Host kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" [ "Welcome to kite!" ] + & Spin.controllerFor clam & ipv4 "66.228.36.95" & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" & alias "kitenet.net" 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 79485569..81ff24f6 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. @@ -93,7 +101,7 @@ 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 @@ -112,10 +120,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 _ = False + +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) -- cgit v1.2.3 From ba71ad4132a19a37b955d5d865253506394581b7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 17 Oct 2015 14:06:57 -0400 Subject: do propigate Controlling info out of containers If someone wants to make a container be a controller, that should work, and it should then detect loops that loop back to the container's host. --- config-joey.hs | 1 - src/Propellor/Property/Spin.hs | 6 ++++-- 2 files changed, 4 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index f862a2fb..e973d35e 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -190,7 +190,6 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf" kite :: Host kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" [ "Welcome to kite!" ] - & Spin.controllerFor clam & ipv4 "66.228.36.95" & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" & alias "kitenet.net" diff --git a/src/Propellor/Property/Spin.hs b/src/Propellor/Property/Spin.hs index 81ff24f6..ee65b0a9 100644 --- a/src/Propellor/Property/Spin.hs +++ b/src/Propellor/Property/Spin.hs @@ -106,7 +106,9 @@ 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 @@ -129,7 +131,7 @@ isControlledBy :: Host -> Controlling -> Bool h `isControlledBy` (Controlled hs) = any (== hostName h) (map hostName hs) instance IsInfo Controlling where - propigateInfo _ = False + propigateInfo _ = True mkControllingInfo :: Host -> Info mkControllingInfo controlled = addInfo mempty (Controlled [controlled]) -- cgit v1.2.3