summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Conductor.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Conductor.hs')
-rw-r--r--src/Propellor/Property/Conductor.hs57
1 files changed, 33 insertions, 24 deletions
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 0d275b91..8aa18d20 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-}
-- | This module adds conductors to propellor. A conductor is a Host that
-- is responsible for running propellor on other hosts
@@ -73,7 +73,8 @@ module Propellor.Property.Conductor (
Conductable(..),
) where
-import Propellor.Base hiding (os)
+import Propellor.Base
+import Propellor.Container
import Propellor.Spin (spin')
import Propellor.PrivData.Paths
import Propellor.Types.Info
@@ -82,21 +83,22 @@ import qualified Propellor.Property.Ssh as Ssh
import qualified Data.Set as S
-- | Class of things that can be conducted.
+--
+-- There are instances for single hosts, and for lists of hosts.
+-- With a list, each listed host 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.
class Conductable c where
- conducts :: c -> RevertableProperty HasInfo
+ conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
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 (toProps $ map (setupRevertableProperty . conducts) hs)
<!>
- propertyList desc (map (toProp . revert . conducts) hs)
+ propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs)
where
desc = cdesc $ unwords $ map hostName hs
@@ -126,7 +128,7 @@ mkOrchestra = fromJust . go S.empty
where
go seen h
| S.member (hostName h) seen = Nothing -- break loop
- | otherwise = Just $ case getInfo (hostInfo h) of
+ | otherwise = Just $ case fromInfo (hostInfo h) of
ConductorFor [] -> Conducted h
ConductorFor l ->
let seen' = S.insert (hostName h) seen
@@ -214,14 +216,15 @@ orchestrate :: [Host] -> [Host]
orchestrate hs = map go hs
where
go h
- | isOrchestrated (getInfo (hostInfo h)) = h
+ | isOrchestrated (fromInfo (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)
+ removeold' h oldconductor = setContainerProps h $ containerProps h
+ ! conductedBy oldconductor
- oldconductors = zip hs (map (getInfo . hostInfo) hs)
+ oldconductors = zip hs (map (fromInfo . hostInfo) hs)
oldconductorsof h = flip mapMaybe oldconductors $
\(oldconductor, NotConductorFor l) ->
if any (sameHost h) l
@@ -232,7 +235,9 @@ 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
+ | any (sameHost h) (map topHost l) = cont $
+ setContainerProps h $ containerProps h
+ & conductedBy c
| otherwise = cont h
where
cont h' = foldl orchestrate' h' l
@@ -240,14 +245,16 @@ orchestrate' h (Conductor c 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)
+conductorFor :: Host -> Property (HasInfo + UnixLike)
+conductorFor h = go
+ `setInfoProperty` (toInfo (ConductorFor [h]))
+ `requires` setupRevertableProperty (conductorKnownHost h)
`requires` Ssh.installed
where
desc = cdesc (hostName h)
- go = ifM (isOrchestrated <$> askInfo)
+ go :: Property UnixLike
+ go = property desc $ ifM (isOrchestrated <$> askInfo)
( do
pm <- liftIO $ filterPrivData h
<$> readPrivDataFile privDataLocal
@@ -262,13 +269,15 @@ conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
)
-- Reverts conductorFor.
-notConductorFor :: Host -> Property HasInfo
-notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotConductorFor [h])) []
- `requires` toProp (revert (conductorKnownHost h))
+notConductorFor :: Host -> Property (HasInfo + UnixLike)
+notConductorFor h = (doNothing :: Property UnixLike)
+ `setInfoProperty` (toInfo (NotConductorFor [h]))
+ `describe` desc
+ `requires` undoRevertableProperty (conductorKnownHost h)
where
desc = "not " ++ cdesc (hostName h)
-conductorKnownHost :: Host -> RevertableProperty NoInfo
+conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike
conductorKnownHost h =
mk Ssh.knownHost
<!>
@@ -287,10 +296,10 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
i = mempty
`addInfo` mconcat (map privinfo hs)
`addInfo` Orchestrated (Any True)
- privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')
+ privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h')
-- Use this property to let the specified conductor ssh in and run propellor.
-conductedBy :: Host -> RevertableProperty NoInfo
+conductedBy :: Host -> RevertableProperty UnixLike UnixLike
conductedBy h = (setup <!> teardown)
`describe` ("conducted by " ++ hostName h)
where