From c742c2eb1b7141fbe0628870e899d3461a88686a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 17:22:35 -0400 Subject: propellor spin --- src/Propellor/Property.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 0728932e..1f602624 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -130,19 +130,19 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 -- > ! oldproperty -- > & otherproperty host :: HostName -> Host -host hn = Host [] (\_ -> newAttr hn) +host hn = Host hn [] (\_ -> newAttr hn) -- | Adds a property to a Host -- -- Can add Properties and RevertableProperties (&) :: IsProp p => Host -> p -> Host -(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as) +(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (setAttr p . as) infixl 1 & -- | Adds a property to the Host in reverted form. (!) :: Host -> RevertableProperty -> Host -(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as) +(Host hn ps as) ! p = Host hn (ps ++ [toProp q]) (setAttr q . as) where q = revert p -- cgit v1.2.3 From 5fc4b006517051e937cbfa13b5f7ccbc25460c1b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 18:02:56 -0400 Subject: remove now redundant _hostname field of Attr Now that Host includes _hostName, it's redundant to also keep it in Attr. This requires changing the reader monad to operate on the whole Host. --- src/Propellor/Attr.hs | 26 +++++--------------------- src/Propellor/CmdLine.hs | 23 ++++++++++------------- src/Propellor/Engine.hs | 23 +++++++++++++++++------ src/Propellor/Property.hs | 2 +- src/Propellor/Property/Dns.hs | 27 +++++++++++++++------------ src/Propellor/Property/Docker.hs | 4 ++-- src/Propellor/Types.hs | 8 ++++---- src/Propellor/Types/Attr.hs | 15 ++++++--------- 8 files changed, 60 insertions(+), 68 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs index 6bc4fcf1..5749a4bf 100644 --- a/src/Propellor/Attr.hs +++ b/src/Propellor/Attr.hs @@ -14,19 +14,15 @@ import Control.Applicative pureAttrProperty :: Desc -> SetAttr -> Property pureAttrProperty desc = Property ("has " ++ desc) (return NoChange) -hostname :: HostName -> Property -hostname name = pureAttrProperty ("hostname " ++ name) $ - \d -> d { _hostname = name } - getHostName :: Propellor HostName -getHostName = asks _hostname +getHostName = asks _hostName os :: System -> Property os system = pureAttrProperty ("Operating " ++ show system) $ \d -> d { _os = Just system } getOS :: Propellor (Maybe System) -getOS = asks _os +getOS = asks (_os . hostAttr) -- | Indidate that a host has an A record in the DNS. -- @@ -74,17 +70,17 @@ addNamedConf conf d = d { _namedconf = new } _ -> M.insert domain conf m getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks _namedconf +getNamedConf = asks (_namedconf . hostAttr) sshPubKey :: String -> Property sshPubKey k = pureAttrProperty ("ssh pubkey known") $ \d -> d { _sshPubKey = Just k } getSshPubKey :: Propellor (Maybe String) -getSshPubKey = asks _sshPubKey +getSshPubKey = asks (_sshPubKey . hostAttr) hostAttr :: Host -> Attr -hostAttr (Host hn _ mkattrs) = mkattrs (newAttr hn) +hostAttr (Host _ _ mkattrs) = mkattrs newAttr hostProperties :: Host -> [Property] hostProperties (Host _ ps _) = ps @@ -92,9 +88,6 @@ hostProperties (Host _ ps _) = ps hostMap :: [Host] -> M.Map HostName Host hostMap l = M.fromList $ zip (map _hostName l) l -hostAttrMap :: [Host] -> M.Map HostName Attr -hostAttrMap l = M.fromList $ zip (map _hostName l) (map hostAttr l) - findHost :: [Host] -> HostName -> Maybe Host findHost l hn = M.lookup hn (hostMap l) @@ -105,12 +98,3 @@ hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of Nothing -> [] Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr - --- | Lifts an action into a different host. --- --- For example, `fromHost hosts "otherhost" getSshPubKey` -fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) -fromHost l hn getter = case findHost l hn of - Nothing -> return Nothing - Just h -> liftIO $ Just <$> - runReaderT (runWithAttr getter) (hostAttr h) diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index ab1d7f9e..a7b7ef96 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -67,24 +67,21 @@ defaultMain hostlist = do go _ (Continue cmdline) = go False cmdline go _ (Set hn field) = setPrivData hn field go _ (AddKey keyid) = addKey keyid - go _ (Chain hn) = withprops hn $ \attr ps -> do - r <- runPropellor attr $ ensureProperties ps + go _ (Chain hn) = withhost hn $ \h -> do + r <- runPropellor h $ ensureProperties $ hostProperties h putStrLn $ "\n" ++ show r go _ (Docker hn) = Docker.chain hn go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin hn) = withprops hn $ const . const $ spin hn + go False (Spin hn) = withhost hn $ const $ spin hn go False (Run hn) = ifM ((==) 0 <$> getRealUserID) - ( onlyProcess $ withprops hn mainProperties + ( onlyProcess $ withhost hn mainProperties , go True (Spin hn) ) - go False (Boot hn) = onlyProcess $ withprops hn boot + go False (Boot hn) = onlyProcess $ withhost hn boot - withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO () - withprops hn a = maybe - (unknownhost hn) - (\h -> a (hostAttr h) (hostProperties h)) - (findHost hostlist hn) + withhost :: HostName -> (Host -> IO ()) -> IO () + withhost hn a = maybe (unknownhost hn) a (findHost hostlist hn) onlyProcess :: IO a -> IO a onlyProcess a = bracket lock unlock (const a) @@ -279,15 +276,15 @@ fromMarked marker s len = length marker matches = filter (marker `isPrefixOf`) $ lines s -boot :: Attr -> [Property] -> IO () -boot attr ps = do +boot :: Host -> IO () +boot h = do sendMarked stdout statusMarker $ show Ready reply <- hGetContentsStrict stdin makePrivDataDir maybe noop (writeFileProtected privDataLocal) $ fromMarked privDataMarker reply - mainProperties attr ps + mainProperties h addKey :: String -> IO () addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ] diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 55ce7f77..9bb3531a 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -5,20 +5,22 @@ module Propellor.Engine where import System.Exit import System.IO import Data.Monoid +import Control.Applicative import System.Console.ANSI import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Message import Propellor.Exception +import Propellor.Attr -runPropellor :: Attr -> Propellor a -> IO a -runPropellor attr a = runReaderT (runWithAttr a) attr +runPropellor :: Host -> Propellor a -> IO a +runPropellor host a = runReaderT (runWithHost a) host -mainProperties :: Attr -> [Property] -> IO () -mainProperties attr ps = do - r <- runPropellor attr $ - ensureProperties [Property "overall" (ensureProperties ps) id] +mainProperties :: Host -> IO () +mainProperties host = do + r <- runPropellor host $ + ensureProperties [Property "overall" (ensureProperties $ hostProperties host) id] setTitle "propellor: done" hFlush stdout case r of @@ -35,3 +37,12 @@ ensureProperties ps = ensure ps NoChange ensureProperty :: Property -> Propellor Result ensureProperty = catchPropellor . propertySatisfy + +-- | Lifts an action into a different host. +-- +-- For example, `fromHost hosts "otherhost" getSshPubKey` +fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) +fromHost l hn getter = case findHost l hn of + Nothing -> return Nothing + Just h -> liftIO $ Just <$> + runReaderT (runWithHost getter) h diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 1f602624..f2a4b3dd 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -130,7 +130,7 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 -- > ! oldproperty -- > & otherproperty host :: HostName -> Host -host hn = Host hn [] (\_ -> newAttr hn) +host hn = Host hn [] (\_ -> newAttr) -- | Adds a property to a Host -- diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 5c3162cb..f82d5494 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -129,9 +129,9 @@ secondaryFor masters hosts domain = RevertableProperty setup cleanup otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] otherServers wantedtype hosts domain = - M.keys $ M.filter wanted $ hostAttrMap hosts + M.keys $ M.filter wanted $ hostMap hosts where - wanted attr = case M.lookup domain (_namedconf attr) of + wanted h = case M.lookup domain (_namedconf $ hostAttr h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -341,7 +341,7 @@ genZone hosts zdomain soa = ] in (Zone zdomain soa (nub zhosts), warnings) where - m = hostAttrMap hosts + m = hostMap hosts -- Known hosts with hostname located in the zone's domain. inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m @@ -350,12 +350,13 @@ genZone hosts zdomain soa = -- -- If a host lacks any IPAddr, it's probably a misconfiguration, -- so warn. - hostips :: Attr -> [Either WarningMessage (BindDomain, Record)] - hostips attr - | null l = [Left $ "no IP address defined for host " ++ _hostname attr] + hostips :: Host -> [Either WarningMessage (BindDomain, Record)] + hostips h + | null l = [Left $ "no IP address defined for host " ++ _hostName h] | otherwise = map Right l where - l = zip (repeat $ AbsDomain $ _hostname attr) + attr = hostAttr h + l = zip (repeat $ AbsDomain $ _hostName h) (map Address $ getAddresses attr) -- Any host, whether its hostname is in the zdomain or not, @@ -370,10 +371,11 @@ genZone hosts zdomain soa = -- -- We typically know the host's IPAddrs anyway. -- So we can just use the IPAddrs. - addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)] - addcnames attr = concatMap gen $ filter (inDomain zdomain) $ + addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] + addcnames h = concatMap gen $ filter (inDomain zdomain) $ mapMaybe getCNAME $ S.toList (_dns attr) where + attr = hostAttr h gen c = case getAddresses attr of [] -> [ret (CNAME c)] l -> map (ret . Address) l @@ -381,10 +383,11 @@ genZone hosts zdomain soa = ret record = Right (c, record) -- Adds any other DNS records for a host located in the zdomain. - hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)] - hostrecords attr = map Right l + hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] + hostrecords h = map Right l where - l = zip (repeat $ AbsDomain $ _hostname attr) + attr = hostAttr h + l = zip (repeat $ AbsDomain $ _hostName h) (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr)) inDomain :: Domain -> BindDomain -> Bool diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index c1340ad9..34a9deb7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,7 +48,7 @@ type ContainerName = String container :: ContainerName -> Image -> Host container cn image = Host hn [] (\_ -> attr) where - attr = (newAttr hn) { _dockerImage = Just image } + attr = newAttr { _dockerImage = Just image } hn = cn2hn cn cn2hn :: ContainerName -> HostName @@ -99,7 +99,7 @@ exposeDnsAttrs :: Host -> Property -> Property exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $ p : map addDNS (S.toList containerdns) where - containerdns = _dns $ containerattr $ newAttr undefined + containerdns = _dns $ containerattr newAttr findContainer :: Maybe Host diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e5f5c1c7..a96e9520 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -42,14 +42,14 @@ data Host = Host , _hostAttrs :: SetAttr } --- | Propellor's monad provides read-only access to attributes of the --- system. -newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p } +-- | Propellor's monad provides read-only access to the host it's running +-- on, including its attributes. +newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p } deriving ( Monad , Functor , Applicative - , MonadReader Attr + , MonadReader Host , MonadIO , MonadCatchIO ) diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs index 8b7d3b09..7f0add10 100644 --- a/src/Propellor/Types/Attr.hs +++ b/src/Propellor/Types/Attr.hs @@ -6,10 +6,9 @@ import qualified Propellor.Types.Dns as Dns import qualified Data.Set as S import qualified Data.Map as M --- | The attributes of a host. For example, its hostname. +-- | The attributes of a host. data Attr = Attr - { _hostname :: HostName - , _os :: Maybe System + { _os :: Maybe System , _sshPubKey :: Maybe String , _dns :: S.Set Dns.Record , _namedconf :: M.Map Dns.Domain Dns.NamedConf @@ -20,8 +19,7 @@ data Attr = Attr instance Eq Attr where x == y = and - [ _hostname x == _hostname y - , _os x == _os y + [ _os x == _os y , _dns x == _dns y , _namedconf x == _namedconf y , _sshPubKey x == _sshPubKey y @@ -33,8 +31,7 @@ instance Eq Attr where instance Show Attr where show a = unlines - [ "hostname " ++ _hostname a - , "OS " ++ show (_os a) + [ "OS " ++ show (_os a) , "sshPubKey " ++ show (_sshPubKey a) , "dns " ++ show (_dns a) , "namedconf " ++ show (_namedconf a) @@ -42,7 +39,7 @@ instance Show Attr where , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) ] -newAttr :: HostName -> Attr -newAttr hn = Attr hn Nothing Nothing S.empty M.empty Nothing [] +newAttr :: Attr +newAttr = Attr Nothing Nothing S.empty M.empty Nothing [] type SetAttr = Attr -> Attr -- cgit v1.2.3 From 4f70fceb3a79f2c2b746407768faf363d11c11a4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 20:39:56 -0400 Subject: 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. --- src/Propellor/Attr.hs | 28 ++++++---------------------- src/Propellor/Engine.hs | 2 +- src/Propellor/Property.hs | 28 ++++++++++++---------------- src/Propellor/Property/Dns.hs | 9 ++++++++- src/Propellor/Property/Docker.hs | 16 +++++++--------- src/Propellor/Types.hs | 19 +++++++++---------- src/Propellor/Types/Attr.hs | 26 +++++++++++++++++++------- src/Propellor/Types/Dns.hs | 20 ++++++++++++++++++++ 8 files changed, 82 insertions(+), 66 deletions(-) (limited to 'src/Propellor/Property.hs') 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 -- cgit v1.2.3