summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-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