summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-21 19:47:15 -0400
committerJoey Hess2015-10-21 19:47:15 -0400
commiteac925f398df39791fe8236f8f8329627761f2e9 (patch)
tree9ce53fbad65c36bb39b5102e6792219b43c34d2a
parent2d1671d5ebdd3c7f99d4023ac621137938505962 (diff)
parent85f08ee913a77c16ba4d264581b1240468c4ebb2 (diff)
Merge branch 'joeyconfig'
-rw-r--r--debian/changelog8
-rw-r--r--propellor.cabal4
-rw-r--r--src/Propellor/CmdLine.hs3
-rw-r--r--src/Propellor/PrivData.hs4
-rw-r--r--src/Propellor/Property/Conductor.hs328
-rw-r--r--src/Propellor/Property/ControlHeir.hs209
-rw-r--r--src/Propellor/Property/File.hs3
-rw-r--r--src/Propellor/Property/Ssh.hs98
-rw-r--r--src/Propellor/Spin.hs77
9 files changed, 457 insertions, 277 deletions
diff --git a/debian/changelog b/debian/changelog
index f8bd5ad5..b4819dd7 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,11 @@
+propellor (2.11.0) UNRELEASED; urgency=medium
+
+ * Rewrote Propellor.Property.ControlHeir one more time, renaming it to
+ Propellor.Property.Conductor.
+ * Added Ssh properties to remove authorized_keys and known_hosts lines.
+
+ -- Joey Hess <id@joeyh.name> Wed, 21 Oct 2015 15:06:26 -0400
+
propellor (2.10.0) unstable; urgency=medium
* The Propellor.Property.Spin added in the last release is replaced
diff --git a/propellor.cabal b/propellor.cabal
index 516bdde2..7471fb52 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 2.10.0
+Version: 2.11.0
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
@@ -76,7 +76,7 @@ Library
Propellor.Property.Apache
Propellor.Property.Apt
Propellor.Property.Cmd
- Propellor.Property.ControlHeir
+ Propellor.Property.Conductor
Propellor.Property.Hostname
Propellor.Property.Chroot
Propellor.Property.ConfFile
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index a0be167e..9f798166 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -119,8 +119,7 @@ defaultMain hostlist = do
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hs mrelay) = do
commitSpin
- forM_ hs $ \hn -> withhost hn $
- spin (maybe RegularSpin RelaySpin mrelay) hn
+ forM_ hs $ \hn -> withhost hn $ spin mrelay hn
go False cmdline@(SimpleRun hn) = buildFirst cmdline $
go False (Run hn)
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 070070f0..aac37d14 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -17,6 +17,7 @@ module Propellor.PrivData (
makePrivDataDir,
decryptPrivData,
readPrivData,
+ readPrivDataFile,
PrivMap,
PrivInfo,
forceHostContext,
@@ -254,6 +255,9 @@ decryptPrivData = readPrivData <$> gpgDecrypt privDataFile
readPrivData :: String -> PrivMap
readPrivData = fromMaybe M.empty . readish
+readPrivDataFile :: FilePath -> IO PrivMap
+readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f
+
makePrivDataDir :: IO ()
makePrivDataDir = createDirectoryIfMissing False privDataDir
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
new file mode 100644
index 00000000..ed46601d
--- /dev/null
+++ b/src/Propellor/Property/Conductor.hs
@@ -0,0 +1,328 @@
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+-- | This module adds conductors to propellor. A conductor is a Host that
+-- is responsible for running propellor on other hosts
+--
+-- This eliminates the need to manually run propellor --spin to
+-- update the conducted hosts, and can be used to orchestrate updates
+-- to hosts.
+--
+-- The conductor needs to be able to ssh to the hosts it conducts,
+-- and run propellor, as root. To this end,
+-- the `Propellor.Property.Ssh.knownHost` property is automatically
+-- added to the conductor, so it knows the host keys of the relevant hosts.
+-- Also, each conducted host is configured to let its conductor
+-- ssh in as root, by automatically adding the
+-- `Propellor.Property.Ssh.authorizedKeysFrom` property.
+--
+-- It's left up to you to use `Propellor.Property.Ssh.userKeys` to
+-- configure the ssh keys for the root user on conductor hosts,
+-- and to use `Ssh.hostKeys` to configure the host keys for the
+-- conducted hosts.
+--
+-- For example, if you have some webservers and a dnsserver,
+-- and want the master host to conduct all of them:
+--
+-- > import Propellor
+-- > import Propellor.Property.Conductor
+-- > import qualified Propellor.Property.Ssh as Ssh
+-- > import qualified Propellor.Property.Cron as Cron
+-- >
+-- > main = defaultMain (orchestrate hosts)
+-- >
+-- > hosts =
+-- > [ master
+-- > , dnsserver
+-- > ] ++ webservers
+-- >
+-- > dnsserver = host "dns.example.com"
+-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")]
+-- > & ...
+-- >
+-- > webservers =
+-- > [ host "www1.example.com"
+-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")]
+-- > & ...
+-- > , ...
+-- > ]
+-- >
+-- > master = host "master.example.com"
+-- > & Ssh.userKeys (User "root") [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")]
+-- > & conducts webservers
+-- > `before` conducts dnsserver
+-- > & Cron.runPropellor
+--
+-- Notice that, in the above example, the the webservers are conducted
+-- first. Only once the webservers have successfully been set up is the
+-- dnsserver updated. This way, when adding a new web server, the dns
+-- won't list it until it's ready.
+--
+-- There can be multiple conductors, and conductors can conduct other
+-- conductors if you need such a hierarchy. (Loops in the hierarchy, such
+-- as a host conducting itself, are detected and automatically broken.)
+--
+-- While it's allowed for a single host to be conducted by
+-- multiple conductors, the results can be discordent.
+-- Since only one propellor process can be run on a host at a time,
+-- one of the conductors will fail to communicate with it.
+--
+-- Note that a conductor can see all PrivData of the hosts it conducts.
+
+module Propellor.Property.Conductor (
+ orchestrate,
+ Conductable(..),
+) where
+
+import Propellor.Base hiding (os)
+import Propellor.Spin (spin')
+import Propellor.PrivData.Paths
+import Propellor.Types.Info
+import qualified Propellor.Property.Ssh as Ssh
+
+import qualified Data.Set as S
+
+-- | Class of things that can be conducted.
+class Conductable c where
+ conducts :: c -> RevertableProperty
+
+instance Conductable Host where
+ -- | Conduct the specified host.
+ conducts h = conductorFor h <!> notConductorFor h
+
+-- | Each host in the list will be conducted in turn. Failure to conduct
+-- one host does not prevent conducting subsequent hosts in the list, but
+-- will be propagated as an overall failure of the property.
+instance Conductable [Host] where
+ conducts hs =
+ propertyList desc (map (toProp . conducts) hs)
+ <!>
+ propertyList desc (map (toProp . revert . conducts) hs)
+ where
+ desc = cdesc $ unwords $ map hostName hs
+
+data Orchestra
+ = Conductor Host [Orchestra]
+ | Conducted Host
+
+instance Show Orchestra where
+ show (Conductor h l) = "Conductor " ++ hostName h ++ " (" ++ show l ++ ")"
+ show (Conducted h) = "Conducted " ++ hostName h
+
+fullOrchestra :: Orchestra -> Bool
+fullOrchestra (Conductor _ _) = True
+fullOrchestra (Conducted _) = False
+
+topHost :: Orchestra -> Host
+topHost (Conducted h) = h
+topHost (Conductor h _) = h
+
+allHosts :: Orchestra -> [Host]
+allHosts (Conducted h) = [h]
+allHosts (Conductor h l) = h : concatMap allHosts l
+
+-- Makes an Orchestra for the host, and any hosts it's conducting.
+mkOrchestra :: Host -> Orchestra
+mkOrchestra = fromJust . go S.empty
+ where
+ go seen h
+ | S.member (hostName h) seen = Nothing -- break loop
+ | otherwise = Just $ case getInfo (hostInfo h) of
+ ConductorFor [] -> Conducted h
+ ConductorFor l ->
+ let seen' = S.insert (hostName h) seen
+ in Conductor h (mapMaybe (go seen') l)
+
+-- Combines the two orchestras, if there's a place, or places where they
+-- can be grafted together.
+combineOrchestras :: Orchestra -> Orchestra -> Maybe Orchestra
+combineOrchestras a b = combineOrchestras' a b <|> combineOrchestras' b a
+
+combineOrchestras' :: Orchestra -> Orchestra -> Maybe Orchestra
+combineOrchestras' (Conducted h) b
+ | sameHost h (topHost b) = Just b
+ | otherwise = Nothing
+combineOrchestras' (Conductor h os) (Conductor h' os')
+ | sameHost h h' = Just $ Conductor h (concatMap combineos os')
+ where
+ combineos o = case mapMaybe (`combineOrchestras` o) os of
+ [] -> [o]
+ os'' -> os''
+combineOrchestras' a@(Conductor h _) (Conducted h')
+ | sameHost h h' = Just a
+combineOrchestras' (Conductor h os) b
+ | null (catMaybes (map snd osgrafts)) = Nothing
+ | otherwise = Just $ Conductor h (map (uncurry fromMaybe) osgrafts)
+ where
+ osgrafts = zip os (map (`combineOrchestras` b) os)
+
+sameHost :: Host -> Host -> Bool
+sameHost a b = hostName a == hostName b
+
+-- Removes any loops that may be present in the Orchestra involving
+-- the passed Host. This is a matter of traversing the Orchestra
+-- top-down, and removing all occurrances of the host after the first
+-- one seen.
+deloop :: Host -> Orchestra -> Orchestra
+deloop _ (Conducted h) = Conducted h
+deloop thehost (Conductor htop ostop) = Conductor htop $
+ fst $ seekh [] ostop (sameHost htop thehost)
+ where
+ seekh l [] seen = (l, seen)
+ seekh l ((Conducted h) : rest) seen
+ | sameHost h thehost =
+ if seen
+ then seekh l rest seen
+ else seekh (Conducted h : l) rest True
+ | otherwise = seekh (Conducted h:l) rest seen
+ seekh l ((Conductor h os) : rest) seen
+ | sameHost h thehost =
+ if seen
+ then seekh l rest seen
+ else
+ let (os', _seen') = seekh [] os True
+ in seekh (Conductor h os' : l) rest True
+ | otherwise =
+ let (os', seen') = seekh [] os seen
+ in seekh (Conductor h os' : l) rest seen'
+
+-- Extracts the Orchestras from a list of hosts.
+--
+-- Method: For each host that is a conductor, check the
+-- list of orchesteras to see if any already contain that host, or
+-- any of the hosts it conducts. If so, add the host to that
+-- orchestra. If not, start a new orchestra.
+--
+-- The result is a set of orchestras, which are each fully disconnected
+-- from the other. Some may contain loops.
+extractOrchestras :: [Host] -> [Orchestra]
+extractOrchestras = filter fullOrchestra . go [] . map mkOrchestra
+ where
+ go os [] = os
+ go os (o:rest) =
+ let os' = zip os (map (combineOrchestras o) os)
+ in case catMaybes (map snd os') of
+ [] -> go (o:os) rest
+ [_] -> go (map (uncurry fromMaybe) os') rest
+ _ -> error "Bug: Host somehow ended up in multiple Orchestras!"
+
+-- | Pass this a list of all your hosts; it will finish setting up
+-- orchestration as configured by the `conducts` properties you add to
+-- hosts.
+--
+-- > main = defaultMain $ orchestrate hosts
+orchestrate :: [Host] -> [Host]
+orchestrate hs = map go hs
+ where
+ go h
+ | isOrchestrated (getInfo (hostInfo h)) = h
+ | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os)
+ os = extractOrchestras hs
+
+ removeold h = foldl removeold' h (oldconductorsof h)
+ removeold' h oldconductor = h & revert (conductedBy oldconductor)
+
+ oldconductors = zip hs (map (getInfo . hostInfo) hs)
+ oldconductorsof h = flip mapMaybe oldconductors $
+ \(oldconductor, NotConductorFor l) ->
+ if any (sameHost h) l
+ then Just oldconductor
+ else Nothing
+
+orchestrate' :: Host -> Orchestra -> Host
+orchestrate' h (Conducted _) = h
+orchestrate' h (Conductor c l)
+ | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
+ | any (sameHost h) (map topHost l) = cont $ h & conductedBy c
+ | otherwise = cont h
+ where
+ cont h' = foldl orchestrate' h' l
+
+-- The host this property is added to becomes the conductor for the
+-- specified Host. Note that `orchestrate` must be used for this property
+-- to have any effect.
+conductorFor :: Host -> Property HasInfo
+conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
+ `requires` toProp (conductorKnownHost h)
+ `requires` Ssh.installed
+ where
+ desc = cdesc (hostName h)
+
+ go = ifM (isOrchestrated <$> askInfo)
+ ( do
+ pm <- liftIO $ filterPrivData h
+ <$> readPrivDataFile privDataLocal
+ liftIO $ spin' (Just pm) Nothing (hostName h) 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.
+ noChange
+ , do
+ warningMessage "Can't conduct; either orchestrate has not been used, or there is a conductor loop."
+ return FailedChange
+ )
+
+-- Reverts conductorFor.
+notConductorFor :: Host -> Property HasInfo
+notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotConductorFor [h])) []
+ `requires` toProp (revert (conductorKnownHost h))
+ where
+ desc = "not " ++ cdesc (hostName h)
+
+conductorKnownHost :: Host -> RevertableProperty
+conductorKnownHost h =
+ mk Ssh.knownHost
+ <!>
+ mk Ssh.unknownHost
+ where
+ mk p = p [h] (hostName h) (User "root")
+
+-- Gives a conductor access to all the PrivData of the specified hosts.
+-- This allows it to send it on the the hosts when conducting it.
+--
+-- This is not done in conductorFor, so that it can be added
+-- at the orchestration stage, and so is not added when there's a loop.
+addConductorPrivData :: Host -> [Host] -> Host
+addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
+ where
+ i = mempty
+ `addInfo` mconcat (map privinfo hs)
+ `addInfo` Orchestrated (Any True)
+ privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')
+
+-- Use this property to let the specified conductor ssh in and run propellor.
+conductedBy :: Host -> RevertableProperty
+conductedBy h = (setup <!> teardown)
+ `describe` ("conducted by " ++ hostName h)
+ where
+ setup = User "root" `Ssh.authorizedKeysFrom` (User "root", h)
+ `requires` Ssh.installed
+ teardown = User "root" `Ssh.unauthorizedKeysFrom` (User "root", h)
+
+cdesc :: String -> Desc
+cdesc n = "conducting " ++ n
+
+-- A Host's Info indicates when it's a conductor for hosts, and when it's
+-- stopped being a conductor.
+newtype ConductorFor = ConductorFor [Host]
+ deriving (Typeable, Monoid)
+newtype NotConductorFor = NotConductorFor [Host]
+ deriving (Typeable, Monoid)
+
+instance Show ConductorFor where
+ show (ConductorFor l) = "ConductorFor " ++ show (map hostName l)
+instance Show NotConductorFor where
+ show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l)
+
+instance IsInfo ConductorFor where
+ propagateInfo _ = False
+instance IsInfo NotConductorFor where
+ propagateInfo _ = False
+
+-- Added to Info when a host has been orchestrated.
+newtype Orchestrated = Orchestrated Any
+ deriving (Typeable, Monoid, Show)
+instance IsInfo Orchestrated where
+ propagateInfo _ = False
+
+isOrchestrated :: Orchestrated -> Bool
+isOrchestrated (Orchestrated v) = getAny v
diff --git a/src/Propellor/Property/ControlHeir.hs b/src/Propellor/Property/ControlHeir.hs
deleted file mode 100644
index 531f884a..00000000
--- a/src/Propellor/Property/ControlHeir.hs
+++ /dev/null
@@ -1,209 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-
-module Propellor.Property.ControlHeir (
- ControlHeir(..),
- ControlList(..),
- addControlHeir,
- ControllerOf(..),
-) where
-
-import Propellor.Base
-import Propellor.Spin (spin, SpinMode(..))
-import Propellor.Types.Info
-import qualified Propellor.Property.Ssh as Ssh
-
--- | A hierarchy of control. When propellor is run on a host that
--- is a Controller, it in turn spins each of the hosts in its control
--- list.
---
--- There can be multiple levels of controllers in the hierarchy.
---
--- Multiple controllers can control the same hosts. However, when
--- propellor is already running on a host, a controller will fail
--- to spin it. So, if two controllers both try to control the same
--- host at the same time, one will fail.
---
--- (Loops in the hierarchy, such as a host controlling itself,
--- are detected and automatically broken.)
-data ControlHeir
- = Controller Host ControlList
- | Controlled Host
-
-instance Show ControlHeir where
- show (Controller h l) = "Controller " ++ hostName h ++ " (" ++ show l ++ ")"
- show (Controlled h) = "Controlled " ++ hostName h
-
-data ControlList
- -- | A list of hosts to control. Failure to spin one host does not
- -- prevent spinning later hosts in the list.
- = ControlList [ControlHeir]
- -- | Requires the first host to be successfully spinned before
- -- proceeding to spin the hosts in the ControlList.
- | ControlReq ControlHeir ControlList
- deriving (Show)
-
-listHeir :: ControlList -> [ControlHeir]
-listHeir (ControlList l) = l
-listHeir (ControlReq h l) = h : listHeir l
-
-class DirectlyControlled a where
- directlyControlled :: a -> [Host]
-
-instance DirectlyControlled ControlHeir where
- directlyControlled (Controlled h) = [h]
- directlyControlled (Controller h _) = [h]
-
-instance DirectlyControlled ControlList where
- directlyControlled = concatMap directlyControlled . listHeir
-
--- Removes any loops that may be present in the ControlHeir involving
--- the passed Host. This is a simple matter of removing the Host from any
--- sub-hierarchies.
-deloop :: Host -> ControlHeir -> ControlHeir
-deloop _ (Controlled h) = Controlled h
-deloop thehost (Controller h cl) = Controller h (removeh cl)
- where
- removeh (ControlList l) = ControlList (mapMaybe removeh' l)
- removeh (ControlReq ch cl') = case removeh' ch of
- Just ch' -> ControlReq ch' (removeh cl')
- Nothing -> removeh cl'
- removeh' (Controlled h')
- | hostName h' == hostName thehost = Nothing
- | otherwise = Just (Controlled h')
- removeh' (Controller h' cl')
- | hostName h' == hostName thehost = Nothing
- | otherwise = Just (Controller h' (removeh cl'))
-
--- | Applies a ControlHeir to a list of hosts.
---
--- This eliminates the need to manually run propellor --spin to
--- update the controlled hosts. Each time propellor is run
--- on the controller host, it will in turn run propellor
--- on each of the controlled Hosts.
---
--- The controller needs to be able to ssh to the hosts it controls,
--- and run propellor, as root. To this end,
--- the `Propellor.Property.Ssh.knownHost` property is added to the
--- controller, so it knows the host keys of the hosts it controlls.
---
--- Each controlled host is configured to let its controller
--- ssh in as root. This is done by adding the
--- `Propellor.Property.Ssh.authorizedKeysFrom` property, with
--- `User "root"`.
---
--- It's left up to you to use `Propellor.Property.Ssh.userKeys` to
--- configure the ssh keys for the root user on controller hosts,
--- and to use `Ssh.hostKeys` to configure the host keys for the controlled
--- hosts.
---
--- For example, if you have some webservers and a dnsserver,
--- and want a master that runs propellor on all of them:
---
--- > import Propellor
--- > import Propellor.Property.ControlHeir
--- > import qualified Propellor.Property.Ssh as Ssh
--- > import qualified Propellor.Property.Cron as Cron
--- >
--- > main = defaultMain (hosts `addControlHeir` control)
--- >
--- > hosts =
--- > [ master
--- > , dnsserver
--- > ] ++ webservers
--- >
--- > control = Controller master (ControlList (map Controlled (dnsserver:webservers)))
--- >
--- > dnsserver = host "dns.example.com"
--- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")]
--- > & ...
--- >
--- > webservers =
--- > [ host "www1.example.com"
--- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")]
--- > & ...
--- > , ...
--- > ]
--- >
--- > master = host "master.example.com"
--- > & Ssh.userKeys (User "root") [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")]
--- > & Cron.runPropellor
---
--- Note that a controller can see all PrivData of the hosts below it in
--- the ControlHeir.
-addControlHeir :: [Host] -> ControlHeir -> [Host]
-addControlHeir hs (Controlled _) = hs
-addControlHeir hs c@(Controller _ _)
- | any isController hs = error "Detected repeated applications of addControlHeir. Since loop prevention only works within a single application, repeated application is unsafe and not allowed."
- | otherwise = map (\h -> addControlHeir' h (deloop h c)) hs
-
--- Walk through the ControlHeir, and add properties to the Host
--- depending on where it appears in the ControlHeir.
--- (Loops are already removed before this point.)
-addControlHeir' :: Host -> ControlHeir -> Host
-addControlHeir' h (Controlled _) = h
-addControlHeir' h (Controller controller l)
- | hn == hostName controller = cont $
- h & mkcontroller l
- | hn `elem` map hostName (directlyControlled l) = cont $
- h & controlledBy controller
- | otherwise = cont h
- where
- hn = hostName h
-
- cont h' = foldl addControlHeir' h' (listHeir l)
-
- mkcontroller (ControlList l') =
- mkcontroller' (concatMap directlyControlled l')
- mkcontroller (ControlReq h' l') =
- mkcontroller' (directlyControlled h')
- `before` mkcontroller l'
- mkcontroller' l' = propertyList
- (cdesc $ unwords $ map hostName l')
- (map controllerFor l')
-
--- | The host this property is added to becomes the controller for the
--- specified Host.
-controllerFor :: Host -> Property HasInfo
-controllerFor h = infoProperty desc go (mkControllingInfo h <> privinfo) []
- `requires` Ssh.knownHost [h] (hostName h) (User "root")
- `requires` Ssh.installed
- where
- desc = cdesc (hostName h)
-
- go = do
- liftIO $ spin ControllingSpin (hostName h) 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.
- noChange
-
- -- Make the controlling host have all the remote host's
- -- PrivData, so it can send it on to the remote host
- -- when spinning it.
- privinfo = addInfo mempty $
- forceHostContext (hostName h) $
- getInfo (hostInfo h)
-
--- | Use this property to let the specified controller Host ssh in
--- and run propellor.
-controlledBy :: Host -> Property NoInfo
-controlledBy h = User "root" `Ssh.authorizedKeysFrom` (User "root", h)
- `requires` Ssh.installed
-
-cdesc :: String -> Desc
-cdesc n = "controller for " ++ n
-
--- | Each Host's info contains a list of the names of hosts it's controlling.
-newtype ControllerOf = ControllerOf [HostName]
- deriving (Typeable, Monoid, Show)
-
-instance IsInfo ControllerOf where
- propagateInfo _ = True
-
-mkControllingInfo :: Host -> Info
-mkControllingInfo controlled = addInfo mempty (ControllerOf [hostName controlled])
-
-isController :: Host -> Bool
-isController h = case getInfo (hostInfo h) of
- ControllerOf [] -> False
- _ -> True
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 08fdc780..7e421cb7 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -67,6 +67,9 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
lacksLine :: FilePath -> Line -> Property NoInfo
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
+lacksLines :: FilePath -> [Line] -> Property NoInfo
+f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f
+
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property NoInfo
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index fa07c6f8..5ba069e3 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -24,9 +24,12 @@ module Propellor.Property.Ssh (
userKeys,
userKeyAt,
knownHost,
+ unknownHost,
authorizedKeysFrom,
+ unauthorizedKeysFrom,
authorizedKeys,
authorizedKey,
+ unauthorizedKey,
hasAuthorizedKeys,
getUserPubKeys,
) where
@@ -300,23 +303,46 @@ fromKeyType SshEd25519 = "ed25519"
-- or `hostKey` into the known_hosts file for a user.
knownHost :: [Host] -> HostName -> User -> Property NoInfo
knownHost hosts hn user@(User u) = property desc $
- go =<< fromHost hosts hn getHostPubKey
+ go =<< knownHostLines hosts hn
where
desc = u ++ " knows ssh key for " ++ hn
- go (Just m) | not (M.null m) = do
- f <- liftIO $ dotFile "known_hosts" user
- ensureProperty $ combineProperties desc
- [ File.dirExists (takeDirectory f)
- , f `File.containsLines`
- (map (\k -> hn ++ " " ++ k) (M.elems m))
- , File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
- go _ = do
+
+ go [] = do
warningMessage $ "no configured ssh host keys for " ++ hn
return FailedChange
+ go ls = do
+ f <- liftIO $ dotFile "known_hosts" user
+ modKnownHost user f $
+ f `File.containsLines` ls
+ `requires` File.dirExists (takeDirectory f)
+
+-- | Reverts `knownHost`
+unknownHost :: [Host] -> HostName -> User -> Property NoInfo
+unknownHost hosts hn user@(User u) = property desc $
+ go =<< knownHostLines hosts hn
+ where
+ desc = u ++ " does not know ssh key for " ++ hn
+
+ go [] = return NoChange
+ go ls = do
+ f <- liftIO $ dotFile "known_hosts" user
+ ifM (liftIO $ doesFileExist f)
+ ( modKnownHost user f $ f `File.lacksLines` ls
+ , return NoChange
+ )
+
+knownHostLines :: [Host] -> HostName -> Propellor [File.Line]
+knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey
+ where
+ keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m)
+ keylines Nothing = []
+
+modKnownHost :: User -> FilePath -> Property NoInfo -> Propellor Result
+modKnownHost user f p = ensureProperty $ p
+ `requires` File.ownerGroup f user (userGroup user)
+ `requires` File.ownerGroup (takeDirectory f) user (userGroup user)
--- | Ensures that a local user's authorized keys contains a line allowing
+-- | Ensures that a local user's authorized_keys contains lines allowing
-- logins from a remote user on the specified Host.
--
-- The ssh keys of the remote user can be set using `keysImported`
@@ -324,15 +350,32 @@ knownHost hosts hn user@(User u) = property desc $
-- Any other lines in the authorized_keys file are preserved as-is.
authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) =
- property desc $ go =<< fromHost' remotehost (getUserPubKeys remoteuser)
+ property desc (go =<< authorizedKeyLines remoteuser remotehost)
where
remote = rn ++ "@" ++ hostName remotehost
desc = ln ++ " authorized_keys from " ++ remote
+
go [] = do
warningMessage $ "no configured ssh user keys for " ++ remote
return FailedChange
- go ks = ensureProperty $ combineProperties desc $
- map (authorizedKey localuser . snd) ks
+ go ls = ensureProperty $ combineProperties desc $
+ map (authorizedKey localuser) ls
+
+-- | Reverts `authorizedKeysFrom`
+unauthorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
+localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) =
+ property desc (go =<< authorizedKeyLines remoteuser remotehost)
+ where
+ remote = rn ++ "@" ++ hostName remotehost
+ desc = ln ++ " unauthorized_keys from " ++ remote
+
+ go [] = return NoChange
+ go ls = ensureProperty $ combineProperties desc $
+ map (unauthorizedKey localuser) ls
+
+authorizedKeyLines :: User -> Host -> Propellor [File.Line]
+authorizedKeyLines remoteuser remotehost =
+ map snd <$> fromHost' remotehost (getUserPubKeys remoteuser)
-- | Makes a user have authorized_keys from the PrivData
--
@@ -354,12 +397,25 @@ authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) contex
authorizedKey :: User -> String -> Property NoInfo
authorizedKey user@(User u) l = property desc $ do
f <- liftIO $ dotFile "authorized_keys" user
- ensureProperty $ combineProperties desc
- [ f `File.containsLine` l
+ modAuthorizedKey f user $
+ f `File.containsLine` l
`requires` File.dirExists (takeDirectory f)
- `onChange` File.mode f (combineModes [ownerWriteMode, ownerReadMode])
- , File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
where
desc = u ++ " has authorized_keys"
+
+-- | Reverts `authorizedKey`
+unauthorizedKey :: User -> String -> Property NoInfo
+unauthorizedKey user@(User u) l = property desc $ do
+ f <- liftIO $ dotFile "authorized_keys" user
+ ifM (liftIO $ doesFileExist f)
+ ( modAuthorizedKey f user $ f `File.lacksLine` l
+ , return NoChange
+ )
+ where
+ desc = u ++ " lacks authorized_keys"
+
+modAuthorizedKey :: FilePath -> User -> Property NoInfo -> Propellor Result
+modAuthorizedKey f user p = ensureProperty $ p
+ `requires` File.mode f (combineModes [ownerWriteMode, ownerReadMode])
+ `requires` File.ownerGroup f user (userGroup user)
+ `requires` File.ownerGroup (takeDirectory f) user (userGroup user)
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 587a7f76..0c457705 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -1,7 +1,7 @@
module Propellor.Spin (
commitSpin,
- SpinMode(..),
spin,
+ spin',
update,
gitPushHelper,
mergeSpin,
@@ -41,41 +41,35 @@ commitSpin = do
void $ actionMessage "Push to central git repository" $
boolSystem "git" [Param "push"]
-data SpinMode
- = RegularSpin
- | RelaySpin HostName
- | ControllingSpin
- deriving (Eq)
+spin :: Maybe HostName -> HostName -> Host -> IO ()
+spin = spin' Nothing
-spin :: SpinMode -> HostName -> Host -> IO ()
-spin spinmode target hst = do
+spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO ()
+spin' mprivdata relay target hst = do
cacheparams <- if viarelay
then pure ["-A"]
else toCommand <$> sshCachingParams hn
when viarelay $
void $ boolSystem "ssh-add" []
- sshtarget <- ("root@" ++) <$> case spinmode of
- RelaySpin r -> pure r
- _ -> getSshTarget target hst
+ sshtarget <- ("root@" ++) <$> case relay of
+ Just r -> pure r
+ Nothing -> getSshTarget target hst
-- Install, or update the remote propellor.
- updateServer target spinmode hst
+ updateServer target relay hst
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
+ getprivdata
-- And now we can run it.
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
error "remote propellor failed"
where
- hn = case spinmode of
- RelaySpin h -> h
- _ -> target
+ hn = fromMaybe target relay
- relaying = spinmode == RelaySpin target
- viarelay = not relaying && case spinmode of
- RelaySpin _ -> True
- _ -> False
+ relaying = relay == Just target
+ viarelay = isJust relay && not relaying
probecmd = intercalate " ; "
[ "if [ ! -d " ++ localdir ++ "/.git ]"
@@ -101,6 +95,17 @@ spin spinmode target hst = do
cmd = if viarelay
then "--serialized " ++ shellEscape (show (Spin [target] (Just target)))
else "--continue " ++ shellEscape (show (SimpleRun target))
+
+ getprivdata = case mprivdata of
+ Nothing
+ | relaying -> do
+ let f = privDataRelay hn
+ d <- readPrivDataFile f
+ nukeFile f
+ return d
+ | otherwise ->
+ filterPrivData hst <$> decryptPrivData
+ Just pd -> pure pd
-- 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,
@@ -180,22 +185,20 @@ update forhost = do
updateServer
:: HostName
- -> SpinMode
+ -> Maybe HostName
-> Host
-> CreateProcess
-> CreateProcess
+ -> IO PrivMap
-> IO ()
-updateServer target spinmode hst connect haveprecompiled =
+updateServer target relay hst connect haveprecompiled getprivdata =
withIOHandles createProcessSuccess connect go
where
- hn = case spinmode of
- RelaySpin h -> h
- _ -> target
- relaying = spinmode == RelaySpin target
+ hn = fromMaybe target relay
go (toh, fromh) = do
let loop = go (toh, fromh)
- let restart = updateServer hn spinmode hst connect haveprecompiled
+ let restart = updateServer hn relay hst connect haveprecompiled getprivdata
let done = return ()
v <- maybe Nothing readish <$> getMarked fromh statusMarker
case v of
@@ -214,36 +217,24 @@ updateServer target spinmode hst connect haveprecompiled =
hClose toh
hClose fromh
sendPrecompiled hn
- updateServer hn spinmode hst haveprecompiled (error "loop")
+ updateServer hn relay hst haveprecompiled (error "loop") getprivdata
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
hClose fromh
hClose toh
done
Nothing -> done
- getprivdata
- | relaying = do
- let f = privDataRelay hn
- d <- readFileStrictAnyEncoding f
- nukeFile f
- return d
- | otherwise = case spinmode of
- -- When one host is controlling another,
- -- the controlling host's privdata includes the
- -- privdata of the controlled host.
- ControllingSpin -> show . filterPrivData hst . readPrivData
- <$> readFileStrictAnyEncoding privDataLocal
- _ -> show . filterPrivData hst <$> decryptPrivData
sendRepoUrl :: Handle -> IO ()
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
-sendPrivData :: HostName -> Handle -> String -> IO ()
+sendPrivData :: HostName -> Handle -> PrivMap -> IO ()
sendPrivData hn toh privdata = void $ actionMessage msg $ do
- sendMarked toh privDataMarker privdata
+ sendMarked toh privDataMarker d
return True
where
- msg = "Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn
+ msg = "Sending privdata (" ++ show (length d) ++ " bytes) to " ++ hn
+ d = show privdata
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
sendGitUpdate hn fromh toh =