summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-05-31 18:02:56 -0400
committerJoey Hess2014-05-31 18:04:41 -0400
commit5fc4b006517051e937cbfa13b5f7ccbc25460c1b (patch)
treef99b7dcf46d262f13aa80fb39c8fcc1a67c951a9
parentd3ac75a1a29e9eda60b78d25e7352d4a2d5713cc (diff)
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.
-rw-r--r--src/Propellor/Attr.hs26
-rw-r--r--src/Propellor/CmdLine.hs23
-rw-r--r--src/Propellor/Engine.hs23
-rw-r--r--src/Propellor/Property.hs2
-rw-r--r--src/Propellor/Property/Dns.hs27
-rw-r--r--src/Propellor/Property/Docker.hs4
-rw-r--r--src/Propellor/Types.hs8
-rw-r--r--src/Propellor/Types/Attr.hs15
8 files changed, 60 insertions, 68 deletions
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