summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Conductor.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 05:53:38 -0400
committerJoey Hess2016-03-28 05:55:48 -0400
commita1655d24bbb1db9caccdf93eae8110d746389ae2 (patch)
tree66b6890d852c19daec2306920fecf9108e055273 /src/Propellor/Property/Conductor.hs
parentebf30061d8f8a251330070e69c2710fe4a8fd9da (diff)
type safe targets for properties
* Property types have been improved to indicate what systems they target. This prevents using eg, Property FreeBSD on a Debian system. Transition guide for this sweeping API change: - Change "host name & foo & bar" to "host name $ props & foo & bar" - Similarly, `propertyList` and `combineProperties` need `props` to be used to combine together properties; they no longer accept lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot, Docker, and Systemd container need `props` to be used to combine together the properies used inside them. - The `os` property is removed. Instead use `osDebian`, `osBuntish`, or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to "RevertableProperty UnixLike UnixLike" - Change "RevertableProperty HasInfo" to "RevertableProperty (HasInfo + UnixLike) UnixLike" - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. This is enabled by default for all modules in propellor.cabal. But if you are using propellor as a library, you may need to enable it manually. - If you know a property only works on a particular OS, like Debian or FreeBSD, use that instead of "UnixLike". For example: "Property Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" - Removed `infoProperty` and `simpleProperty` constructors, instead use `property` to construct a Property. - Due to the polymorphic type returned by `property`, additional type signatures tend to be needed when using it. For example, this will fail to type check, because the type checker cannot guess what type you intend the intermediate property "go" to have: foo :: Property UnixLike foo = go `requires` bar where go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - `ensureProperty` now needs to be passed a witness to the type of the property it's used in. change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \w -> ... ensureProperty w bar - General purpose properties like cmdProperty have type "Property UnixLike". When using that to run a command only available on Debian, you can tighten the type to only the OS that your more specific property works on. For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - Several utility functions have been renamed: getInfo to fromInfo propertyInfo to getInfo propertyDesc to getDesc propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses which to use based on the Host's OS. * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling these complex new types. * Added dependency on concurrent-output; removed embedded copy.
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