diff options
| -rw-r--r-- | src/Propellor/Attr.hs | 28 | ||||
| -rw-r--r-- | src/Propellor/Engine.hs | 2 | ||||
| -rw-r--r-- | src/Propellor/Property.hs | 28 | ||||
| -rw-r--r-- | src/Propellor/Property/Dns.hs | 9 | ||||
| -rw-r--r-- | src/Propellor/Property/Docker.hs | 16 | ||||
| -rw-r--r-- | src/Propellor/Types.hs | 19 | ||||
| -rw-r--r-- | src/Propellor/Types/Attr.hs | 26 | ||||
| -rw-r--r-- | src/Propellor/Types/Dns.hs | 20 |
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 |