summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-05-31 20:39:56 -0400
committerJoey Hess2014-05-31 20:43:23 -0400
commit4f70fceb3a79f2c2b746407768faf363d11c11a4 (patch)
tree3f0c05ed545b761bbe3f07576d1ef0259a48c4af
parent6b835c5eeb352718a11e707a0e10d2bc5092782b (diff)
got rid of the Attr -> Attr SetAttr hack, and use monoids for Attr
The SetAttr hack used to be needed because the hostname was part of the Attr, and was required to be present. Now that it's moved to Host, let's get rid of that, since it tended to waste CPU.
-rw-r--r--src/Propellor/Attr.hs28
-rw-r--r--src/Propellor/Engine.hs2
-rw-r--r--src/Propellor/Property.hs28
-rw-r--r--src/Propellor/Property/Dns.hs9
-rw-r--r--src/Propellor/Property/Docker.hs16
-rw-r--r--src/Propellor/Types.hs19
-rw-r--r--src/Propellor/Types/Attr.hs26
-rw-r--r--src/Propellor/Types/Dns.hs20
8 files changed, 82 insertions, 66 deletions
diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs
index 5749a4bf..8f1c6b7c 100644
--- a/src/Propellor/Attr.hs
+++ b/src/Propellor/Attr.hs
@@ -9,9 +9,10 @@ import "mtl" Control.Monad.Reader
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Maybe
+import Data.Monoid
import Control.Applicative
-pureAttrProperty :: Desc -> SetAttr -> Property
+pureAttrProperty :: Desc -> Attr -> Property
pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
getHostName :: Propellor HostName
@@ -19,7 +20,7 @@ getHostName = asks _hostName
os :: System -> Property
os system = pureAttrProperty ("Operating " ++ show system) $
- \d -> d { _os = Just system }
+ mempty { _os = Just system }
getOS :: Propellor (Maybe System)
getOS = asks (_os . hostAttr)
@@ -41,7 +42,7 @@ alias = addDNS . CNAME . AbsDomain
addDNS :: Record -> Property
addDNS r = pureAttrProperty (rdesc r) $
- \d -> d { _dns = S.insert r (_dns d) }
+ mempty { _dns = S.singleton r }
where
rdesc (CNAME d) = unwords ["alias", ddesc d]
rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
@@ -55,32 +56,15 @@ addDNS r = pureAttrProperty (rdesc r) $
ddesc (RelDomain domain) = domain
ddesc RootDomain = "@"
--- | Adds a DNS NamedConf stanza.
---
--- Note that adding a Master stanza for a domain always overrides an
--- existing Secondary stanza, while a Secondary stanza is only added
--- when there is no existing Master stanza.
-addNamedConf :: NamedConf -> SetAttr
-addNamedConf conf d = d { _namedconf = new }
- where
- m = _namedconf d
- domain = confDomain conf
- new = case (confDnsServerType conf, confDnsServerType <$> M.lookup domain m) of
- (Secondary, Just Master) -> m
- _ -> M.insert domain conf m
-
-getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks (_namedconf . hostAttr)
-
sshPubKey :: String -> Property
sshPubKey k = pureAttrProperty ("ssh pubkey known") $
- \d -> d { _sshPubKey = Just k }
+ mempty { _sshPubKey = Just k }
getSshPubKey :: Propellor (Maybe String)
getSshPubKey = asks (_sshPubKey . hostAttr)
hostAttr :: Host -> Attr
-hostAttr (Host _ _ mkattrs) = mkattrs newAttr
+hostAttr (Host _ _ attr) = attr
hostProperties :: Host -> [Property]
hostProperties (Host _ ps _) = ps
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 1fba6a23..7cee42e8 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -20,7 +20,7 @@ runPropellor host a = runReaderT (runWithHost a) host
mainProperties :: Host -> IO ()
mainProperties host = do
r <- runPropellor host $
- ensureProperties [Property "overall" (ensureProperties $ hostProperties host) id]
+ ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
setTitle "propellor: done"
hFlush stdout
case r of
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index f2a4b3dd..e3d46eae 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -5,12 +5,10 @@ module Propellor.Property where
import System.Directory
import Control.Monad
import Data.Monoid
-import Data.List
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
import Propellor.Types
-import Propellor.Types.Attr
import Propellor.Attr
import Propellor.Engine
import Utility.Monad
@@ -18,19 +16,19 @@ import System.FilePath
-- Constructs a Property.
property :: Desc -> Propellor Result -> Property
-property d s = Property d s id
+property d s = Property d s mempty
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc (ensureProperties ps) (combineSetAttrs ps)
+propertyList desc ps = Property desc (ensureProperties ps) (combineAttrs ps)
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn, stopping on failure.
combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)
+combineProperties desc ps = Property desc (go ps NoChange) (combineAttrs ps)
where
go [] rs = return rs
go (l:ls) rs = do
@@ -69,7 +67,7 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
--- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange :: Property -> Property -> Property
-p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)
+p `onChange` hook = Property (propertyDesc p) satisfy (combineAttr p hook)
where
satisfy = do
r <- ensureProperty p
@@ -130,21 +128,19 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
-- > ! oldproperty
-- > & otherproperty
host :: HostName -> Host
-host hn = Host hn [] (\_ -> newAttr)
+host hn = Host hn [] mempty
-- | Adds a property to a Host
--
-- Can add Properties and RevertableProperties
(&) :: IsProp p => Host -> p -> Host
-(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (setAttr p . as)
+(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (as <> getAttr p)
infixl 1 &
-- | Adds a property to the Host in reverted form.
(!) :: Host -> RevertableProperty -> Host
-(Host hn ps as) ! p = Host hn (ps ++ [toProp q]) (setAttr q . as)
- where
- q = revert p
+h ! p = h & revert p
infixl 1 !
@@ -152,12 +148,12 @@ infixl 1 !
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
--- Combines the Attr settings of two properties.
-combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr
-combineSetAttr p q = setAttr p . setAttr q
+-- Combines the Attr of two properties.
+combineAttr :: (IsProp p, IsProp q) => p -> q -> Attr
+combineAttr p q = getAttr p <> getAttr q
-combineSetAttrs :: IsProp p => [p] -> SetAttr
-combineSetAttrs = foldl' (.) id . map setAttr
+combineAttrs :: IsProp p => [p] -> Attr
+combineAttrs = mconcat . map getAttr
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index f82d5494..44378491 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -131,7 +131,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
otherServers wantedtype hosts domain =
M.keys $ M.filter wanted $ hostMap hosts
where
- wanted h = case M.lookup domain (_namedconf $ hostAttr h) of
+ wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostAttr h) of
Nothing -> False
Just conf -> confDnsServerType conf == wantedtype
&& confDomain conf == domain
@@ -406,3 +406,10 @@ domainHost base (AbsDomain d)
where
dotbase = '.':base
+addNamedConf :: NamedConf -> Attr
+addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) }
+ where
+ domain = confDomain conf
+
+getNamedConf :: Propellor (M.Map Domain NamedConf)
+getNamedConf = asks $ fromNamedConfMap . _namedconf . hostAttr
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 34a9deb7..3e925bb6 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -46,9 +46,9 @@ type ContainerName = String
-- > & Apt.installed {"apache2"]
-- > & ...
container :: ContainerName -> Image -> Host
-container cn image = Host hn [] (\_ -> attr)
+container cn image = Host hn [] attr
where
- attr = newAttr { _dockerImage = Just image }
+ attr = mempty { _dockerImage = Just image }
hn = cn2hn cn
cn2hn :: ContainerName -> HostName
@@ -97,9 +97,7 @@ docked hosts cn = RevertableProperty
exposeDnsAttrs :: Host -> Property -> Property
exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $
- p : map addDNS (S.toList containerdns)
- where
- containerdns = _dns $ containerattr newAttr
+ p : map addDNS (S.toList $ _dns containerattr)
findContainer
:: Maybe Host
@@ -422,14 +420,14 @@ listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property
-runProp field val = pureAttrProperty (param) $ \attr ->
- attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
+runProp field val = pureAttrProperty (param) $
+ mempty { _dockerRunParams = [\_ -> "--"++param] }
where
param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property
-genProp field mkval = pureAttrProperty field $ \attr ->
- attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
+genProp field mkval = pureAttrProperty field $
+ mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }
-- | The ContainerIdent of a container is written to
-- /.propellor-ident inside it. This can be checked to see if
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index a96e9520..e0d471ff 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -4,14 +4,13 @@
module Propellor.Types
( Host(..)
, Attr
- , SetAttr
+ , getAttr
, Propellor(..)
, Property(..)
, RevertableProperty(..)
, IsProp
, describe
, toProp
- , setAttr
, requires
, Desc
, Result(..)
@@ -39,7 +38,7 @@ import Propellor.Types.Dns
data Host = Host
{ _hostName :: HostName
, _hostProps :: [Property]
- , _hostAttrs :: SetAttr
+ , _hostAttr :: Attr
}
-- | Propellor's monad provides read-only access to the host it's running
@@ -61,8 +60,8 @@ data Property = Property
{ propertyDesc :: Desc
, propertySatisfy :: Propellor Result
-- ^ must be idempotent; may run repeatedly
- , propertyAttr :: SetAttr
- -- ^ a property can set an Attr on the host that has the property.
+ , propertyAttr :: Attr
+ -- ^ a property can set an attribute of the host that has the property.
}
-- | A property that can be reverted.
@@ -75,15 +74,15 @@ class IsProp p where
-- | Indicates that the first property can only be satisfied
-- once the second one is.
requires :: p -> Property -> p
- setAttr :: p -> SetAttr
+ getAttr :: p -> Attr
instance IsProp Property where
describe p d = p { propertyDesc = d }
toProp p = p
- setAttr = propertyAttr
+ getAttr = propertyAttr
x `requires` y = Property (propertyDesc x) satisfy attr
where
- attr = propertyAttr x . propertyAttr y
+ attr = getAttr y <> getAttr x
satisfy = do
r <- propertySatisfy y
case r of
@@ -98,8 +97,8 @@ instance IsProp RevertableProperty where
toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2
- -- | Return the SetAttr of the currently active side.
- setAttr (RevertableProperty p1 _p2) = setAttr p1
+ -- | Return the Attr of the currently active side.
+ getAttr (RevertableProperty p1 _p2) = getAttr p1
type Desc = String
diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs
index 7f0add10..4c891a46 100644
--- a/src/Propellor/Types/Attr.hs
+++ b/src/Propellor/Types/Attr.hs
@@ -4,14 +4,14 @@ import Propellor.Types.OS
import qualified Propellor.Types.Dns as Dns
import qualified Data.Set as S
-import qualified Data.Map as M
+import Data.Monoid
-- | The attributes of a host.
data Attr = Attr
{ _os :: Maybe System
, _sshPubKey :: Maybe String
, _dns :: S.Set Dns.Record
- , _namedconf :: M.Map Dns.Domain Dns.NamedConf
+ , _namedconf :: Dns.NamedConfMap
, _dockerImage :: Maybe String
, _dockerRunParams :: [HostName -> String]
@@ -29,6 +29,23 @@ instance Eq Attr where
in simpl x == simpl y
]
+instance Monoid Attr where
+ mempty = Attr Nothing Nothing mempty mempty Nothing mempty
+ mappend old new = Attr
+ { _os = case _os new of
+ Just v -> Just v
+ Nothing -> _os old
+ , _sshPubKey = case _sshPubKey new of
+ Just v -> Just v
+ Nothing -> _sshPubKey old
+ , _dns = _dns new <> _dns old
+ , _namedconf = _namedconf new <> _namedconf old
+ , _dockerImage = case _dockerImage new of
+ Just v -> Just v
+ Nothing -> _dockerImage old
+ , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
+ }
+
instance Show Attr where
show a = unlines
[ "OS " ++ show (_os a)
@@ -38,8 +55,3 @@ instance Show Attr where
, "docker image " ++ show (_dockerImage a)
, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
]
-
-newAttr :: Attr
-newAttr = Attr Nothing Nothing S.empty M.empty Nothing []
-
-type SetAttr = Attr -> Attr
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index ba6a92dd..66fbd1a4 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -3,6 +3,8 @@ module Propellor.Types.Dns where
import Propellor.Types.OS (HostName)
import Data.Word
+import Data.Monoid
+import qualified Data.Map as M
type Domain = String
@@ -90,3 +92,21 @@ domainHostName :: BindDomain -> Maybe HostName
domainHostName (RelDomain d) = Just d
domainHostName (AbsDomain d) = Just d
domainHostName RootDomain = Nothing
+
+newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
+ deriving (Eq, Ord, Show)
+
+-- | Adding a Master NamedConf stanza for a particulr domain always
+-- overrides an existing Secondary stanza for that domain, while a
+-- Secondary stanza is only added when there is no existing Master stanza.
+instance Monoid NamedConfMap where
+ mempty = NamedConfMap M.empty
+ mappend (NamedConfMap old) (NamedConfMap new) = NamedConfMap $
+ M.unionWith combiner new old
+ where
+ combiner n o = case (confDnsServerType n, confDnsServerType o) of
+ (Secondary, Master) -> o
+ _ -> n
+
+fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf
+fromNamedConfMap (NamedConfMap m) = m