summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--config-joey.hs32
-rw-r--r--debian/changelog11
-rw-r--r--doc/todo/docker_todo_list.mdwn5
-rw-r--r--propellor.cabal8
-rw-r--r--src/Propellor/Attr.hs84
-rw-r--r--src/Propellor/CmdLine.hs23
-rw-r--r--src/Propellor/Engine.hs26
-rw-r--r--src/Propellor/Message.hs19
-rw-r--r--src/Propellor/PrivData.hs3
-rw-r--r--src/Propellor/Property.hs28
-rw-r--r--src/Propellor/Property/Dns.hs34
-rw-r--r--src/Propellor/Property/Docker.hs37
-rw-r--r--src/Propellor/Property/Hostname.hs2
-rw-r--r--src/Propellor/Property/Postfix.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs13
-rw-r--r--src/Propellor/Types.hs35
-rw-r--r--src/Propellor/Types/Attr.hs37
-rw-r--r--src/Propellor/Types/Dns.hs20
18 files changed, 241 insertions, 178 deletions
diff --git a/config-joey.hs b/config-joey.hs
index e67bcede..ae575ea7 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -41,7 +41,7 @@ hosts = -- (o) `
& Apt.buildDep ["git-annex"] `period` Daily
& Docker.docked hosts "android-git-annex"
- -- Nothing super-important lives here.
+ -- Nothing super-important lives here and mostly it's docker containers.
, standardSystem "clam.kitenet.net" Unstable "amd64"
& ipv4 "162.248.143.249"
& ipv6 "2002:5044:5531::1"
@@ -53,14 +53,9 @@ hosts = -- (o) `
& Postfix.satellite
& Docker.configured
- & alias "shell.olduse.net"
- & JoeySites.oldUseNetShellBox
-
- & alias "openid.kitenet.net"
+ & Docker.docked hosts "oldusenet-shellbox"
& Docker.docked hosts "openid-provider"
`requires` Apt.serviceInstalledRunning "ntp"
-
- & alias "ancient.kitenet.net"
& Docker.docked hosts "ancient-kitenet"
-- I'd rather this were on diatom, but it needs unstable.
@@ -76,9 +71,15 @@ hosts = -- (o) `
& alias "znc.kitenet.net"
& JoeySites.ircBouncer
- -- Nothing is using https on clam, so listen on that port
- -- for ssh, for traveling on bad networks.
- & "/etc/ssh/sshd_config" `File.containsLine` "Port 443"
+ -- For https port 443, shellinabox with ssh login to
+ -- kitenet.net
+ & alias "shell.kitenet.net"
+ & JoeySites.kiteShellBox
+
+ -- Nothing is using http port 80 on clam, so listen on
+ -- that port for ssh, for traveling on bad networks that
+ -- block 22.
+ & "/etc/ssh/sshd_config" `File.containsLine` "Port 80"
`onChange` Service.restarted "ssh"
& Docker.garbageCollected `period` Daily
@@ -179,17 +180,24 @@ hosts = -- (o) `
-- My own openid provider. Uses php, so containerized for security
-- and administrative sanity.
, standardContainer "openid-provider" Stable "amd64"
+ & alias "openid.kitenet.net"
& Docker.publish "8081:80"
& OpenId.providerFor ["joey", "liw"]
"openid.kitenet.net:8081"
-- Exhibit: kite's 90's website.
, standardContainer "ancient-kitenet" Stable "amd64"
+ & alias "ancient.kitenet.net"
& Docker.publish "1994:80"
& Apt.serviceInstalledRunning "apache2"
& Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www"
(Just "remotes/origin/old-kitenet.net")
+ , standardContainer "oldusenet-shellbox" Stable "amd64"
+ & alias "shell.olduse.net"
+ & Docker.publish "4200:4200"
+ & JoeySites.oldUseNetShellBox
+
-- git-annex autobuilder containers
, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h"
, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h"
@@ -307,7 +315,6 @@ monsters = -- but do want to track their public keys etc.
& alias "www.wortroot.kitenet.net"
& alias "joey.kitenet.net"
& alias "anna.kitenet.net"
- & alias "ipv6.kitenet.net"
& alias "bitlbee.kitenet.net"
{- Remaining services on kite:
-
@@ -329,11 +336,10 @@ monsters = -- but do want to track their public keys etc.
- (branchable is still pushing to here
- (thinking it's ns2.branchable.com), but it's no
- longer a primary or secondary for anything)
- - ajaxterm
- ftpd (EOL)
-
- user shell stuff:
- - pine, zsh, make, ...
+ - pine, zsh, make, git-annex, myrepos, ...
-}
, host "mouse.kitenet.net"
& ipv6 "2001:4830:1600:492::2"
diff --git a/debian/changelog b/debian/changelog
index 916b9b3b..695ea3fc 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,14 @@
+propellor (0.6.0) UNRELEASED; urgency=medium
+
+ * Docker containers now propigate DNS attributes out to the host they're
+ docked in. So if a docker container sets a DNS alias, every container
+ it's docked in will automatically become part of a round-robin DNS,
+ if propellor is used to manage DNS for the domain.
+ * Propellor's output now includes the hostname being provisioned, or
+ when provisioning a docker container, the container name.
+
+ -- Joey Hess <joeyh@debian.org> Sat, 31 May 2014 16:41:56 -0400
+
propellor (0.5.3) unstable; urgency=medium
* Fix unattended-upgrades config for !stable.
diff --git a/doc/todo/docker_todo_list.mdwn b/doc/todo/docker_todo_list.mdwn
index 65762cff..1321445d 100644
--- a/doc/todo/docker_todo_list.mdwn
+++ b/doc/todo/docker_todo_list.mdwn
@@ -1,8 +1,3 @@
-* Display of docker container properties is a bit wonky. It always
- says they are unchanged even when they changed and triggered a
- reprovision.
* There is no way for a property of a docker container to require
some property be met outside the container. For example, some servers
need ntp installed for a good date source.
-* Docking a container in a host should add to the host any cnames that
- are assigned to the container.
diff --git a/propellor.cabal b/propellor.cabal
index 80c353bc..67a418e5 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 0.5.3
+Version: 0.6.0
Cabal-Version: >= 1.6
License: BSD3
Maintainer: Joey Hess <joey@kitenet.net>
@@ -35,7 +35,7 @@ Description:
Executable wrapper
Main-Is: wrapper.hs
- GHC-Options: -Wall -threaded
+ GHC-Options: -Wall -threaded -O0
Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
@@ -47,7 +47,7 @@ Executable wrapper
Executable config
Main-Is: config.hs
- GHC-Options: -Wall -threaded
+ GHC-Options: -Wall -threaded -0O
Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
@@ -58,7 +58,7 @@ Executable config
Build-Depends: unix
Library
- GHC-Options: -Wall
+ GHC-Options: -Wall -O0
Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs
index 98cfc64d..29d7a01e 100644
--- a/src/Propellor/Attr.hs
+++ b/src/Propellor/Attr.hs
@@ -9,86 +9,59 @@ 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)
-hostname :: HostName -> Property
-hostname name = pureAttrProperty ("hostname " ++ name) $
- \d -> d { _hostname = name }
-
-getHostName :: Propellor HostName
-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
+getOS = asks (_os . hostAttr)
-- | Indidate that a host has an A record in the DNS.
--
-- TODO check at run time if the host really has this address.
-- (Can't change the host's address, but as a sanity check.)
ipv4 :: String -> Property
-ipv4 addr = pureAttrProperty ("ipv4 " ++ addr)
- (addDNS $ Address $ IPv4 addr)
+ipv4 = addDNS . Address . IPv4
-- | Indidate that a host has an AAAA record in the DNS.
ipv6 :: String -> Property
-ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)
- (addDNS $ Address $ IPv6 addr)
+ipv6 = addDNS . Address . IPv6
-- | Indicates another name for the host in the DNS.
alias :: Domain -> Property
-alias domain = pureAttrProperty ("alias " ++ domain)
- (addDNS $ CNAME $ AbsDomain domain)
-
-addDNS :: Record -> SetAttr
-addDNS record d = d { _dns = S.insert record (_dns d) }
+alias = addDNS . CNAME . AbsDomain
--- | 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 }
+addDNS :: Record -> Property
+addDNS r = pureAttrProperty (rdesc r) $
+ mempty { _dns = S.singleton r }
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
+ rdesc (CNAME d) = unwords ["alias", ddesc d]
+ rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
+ rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr]
+ rdesc (MX n d) = unwords ["MX", show n, ddesc d]
+ rdesc (NS d) = unwords ["NS", ddesc d]
+ rdesc (TXT s) = unwords ["TXT", s]
+ rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]
+
+ ddesc (AbsDomain domain) = domain
+ ddesc (RelDomain domain) = domain
+ ddesc RootDomain = "@"
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
-
-hostnameless :: Attr
-hostnameless = newAttr (error "hostname Attr not specified")
-
-hostAttr :: Host -> Attr
-hostAttr (Host _ mkattrs) = mkattrs hostnameless
-
-hostProperties :: Host -> [Property]
-hostProperties (Host ps _) = ps
+getSshPubKey = asks (_sshPubKey . hostAttr)
hostMap :: [Host] -> M.Map HostName Host
-hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l
-
-hostAttrMap :: [Host] -> M.Map HostName Attr
-hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs
- where
- attrs = map hostAttr l
+hostMap l = M.fromList $ zip (map hostName l) l
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = M.lookup hn (hostMap l)
@@ -100,12 +73,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..ca0f7265 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) mempty]
setTitle "propellor: done"
hFlush stdout
case r of
@@ -30,8 +32,18 @@ ensureProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
ensure (l:ls) rs = do
- r <- actionMessage (propertyDesc l) (ensureProperty l)
+ hn <- asks hostName
+ r <- actionMessageOn hn (propertyDesc l) (ensureProperty l)
ensure ls (r <> rs)
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/Message.hs b/src/Propellor/Message.hs
index 780471c3..afbed1ca 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -12,7 +12,15 @@ import Propellor.Types
-- | Shows a message while performing an action, with a colored status
-- display.
actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
-actionMessage desc a = do
+actionMessage = actionMessage' Nothing
+
+-- | Shows a message while performing an action on a specified host,
+-- with a colored status display.
+actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r
+actionMessageOn = actionMessage' . Just
+
+actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
+actionMessage' mhn desc a = do
liftIO $ do
setTitle $ "propellor: " ++ desc
hFlush stdout
@@ -21,12 +29,19 @@ actionMessage desc a = do
liftIO $ do
setTitle "propellor: running"
- let (msg, intensity, color) = getActionResult r
+ showhn mhn
putStr $ desc ++ " ... "
+ let (msg, intensity, color) = getActionResult r
colorLine intensity color msg
hFlush stdout
return r
+ where
+ showhn Nothing = return ()
+ showhn (Just hn) = do
+ setSGR [SetColor Foreground Dull Cyan]
+ putStr (hn ++ " ")
+ setSGR []
warningMessage :: MonadIO m => String -> m ()
warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index ad2c8d22..54f67d73 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -13,7 +13,6 @@ import Control.Monad
import "mtl" Control.Monad.Reader
import Propellor.Types
-import Propellor.Attr
import Propellor.Message
import Utility.Monad
import Utility.PartialPrelude
@@ -30,7 +29,7 @@ withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Resul
withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
where
missing = do
- host <- getHostName
+ host <- asks hostName
let host' = if ".docker" `isSuffixOf` host
then "$parent_host"
else host
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 0728932e..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 [] (\_ -> newAttr hn)
+host hn = Host hn [] mempty
-- | 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]) (as <> getAttr p)
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)
- 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 5c3162cb..3e5c7828 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 (fromNamedConfMap $ _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
@@ -403,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 68fbced5..8e081ae4 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -21,6 +21,7 @@ import System.Posix.Directory
import System.Posix.Process
import Data.List
import Data.List.Utils
+import qualified Data.Set as S
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io.
@@ -45,16 +46,20 @@ type ContainerName = String
-- > & Apt.installed {"apache2"]
-- > & ...
container :: ContainerName -> Image -> Host
-container cn image = Host [] (\_ -> attr)
+container cn image = Host hn [] attr
where
- attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
+ attr = mempty { _dockerImage = Just image }
+ hn = cn2hn cn
cn2hn :: ContainerName -> HostName
cn2hn cn = cn ++ ".docker"
-- | Ensures that a docker container is set up and running. The container
-- has its own Properties which are handled by running propellor
--- inside the container.
+-- inside the container.
+--
+-- Additionally, the container can have DNS attributes, such as a CNAME.
+-- These become attributes of the host(s) it's docked in.
--
-- Reverting this property ensures that the container is stopped and
-- removed.
@@ -62,12 +67,16 @@ docked
:: [Host]
-> ContainerName
-> RevertableProperty
-docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
+docked hosts cn = RevertableProperty
+ ((maybe id exposeDnsAttrs mhost) (go "docked" setup))
+ (go "undocked" teardown)
where
go desc a = property (desc ++ " " ++ cn) $ do
- hn <- getHostName
+ hn <- asks hostName
let cid = ContainerId hn cn
- ensureProperties [findContainer hosts cid cn $ a cid]
+ ensureProperties [findContainer mhost cid cn $ a cid]
+
+ mhost = findHost hosts (cn2hn cn)
setup cid (Container image runparams) =
provisionContainer cid
@@ -86,13 +95,17 @@ docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown
]
]
+exposeDnsAttrs :: Host -> Property -> Property
+exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $
+ p : map addDNS (S.toList $ _dns containerattr)
+
findContainer
- :: [Host]
+ :: Maybe Host
-> ContainerId
-> ContainerName
-> (Container -> Property)
-> Property
-findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
+findContainer mhost cid cn mk = case mhost of
Nothing -> cantfind
Just h -> maybe cantfind mk (mkContainer cid h)
where
@@ -407,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/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 3859649e..3a6283cf 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.File as File
-- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is
-- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).
sane :: Property
-sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName)
+sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
setTo :: HostName -> Property
setTo hn = combineProperties desc go
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 9fa4a2c3..ef96e086 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -16,7 +16,7 @@ satellite :: Property
satellite = setup `requires` installed
where
setup = trivial $ property "postfix satellite system" $ do
- hn <- getHostName
+ hn <- asks hostName
ensureProperty $ Apt.reConfigure "postfix"
[ ("postfix/main_mailer_type", "select", "Satellite system")
, ("postfix/root_address", "string", "root")
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 587e16af..f6e1e37f 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -317,3 +317,16 @@ ircBouncer = propertyList "IRC bouncer"
]
where
conf = "/home/znc/.znc/configs/znc.conf"
+
+kiteShellBox :: Property
+kiteShellBox = propertyList "kitenet.net shellinabox"
+ [ Apt.installed ["shellinabox"]
+ , File.hasContent "/etc/default/shellinabox"
+ [ "# Deployed by propellor"
+ , "SHELLINABOX_DAEMON_START=1"
+ , "SHELLINABOX_PORT=443"
+ , "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\""
+ ]
+ `onChange` Service.restarted "shellinabox"
+ , Service.running "shellinabox"
+ ]
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 8a4bd3dd..4ea97bce 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(..)
@@ -34,18 +33,22 @@ import Propellor.Types.Attr
import Propellor.Types.OS
import Propellor.Types.Dns
--- | Everything Propellor knows about a system: Its properties and
--- attributes.
-data Host = Host [Property] SetAttr
+-- | Everything Propellor knows about a system: Its hostname,
+-- properties and attributes.
+data Host = Host
+ { hostName :: HostName
+ , hostProperties :: [Property]
+ , hostAttr :: Attr
+ }
--- | 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
)
@@ -57,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.
@@ -71,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
@@ -94,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 8b7d3b09..4c891a46 100644
--- a/src/Propellor/Types/Attr.hs
+++ b/src/Propellor/Types/Attr.hs
@@ -4,15 +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. 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
+ , _namedconf :: Dns.NamedConfMap
, _dockerImage :: Maybe String
, _dockerRunParams :: [HostName -> String]
@@ -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
@@ -31,18 +29,29 @@ 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
- [ "hostname " ++ _hostname a
- , "OS " ++ show (_os a)
+ [ "OS " ++ show (_os a)
, "sshPubKey " ++ show (_sshPubKey a)
, "dns " ++ show (_dns a)
, "namedconf " ++ show (_namedconf a)
, "docker image " ++ show (_dockerImage a)
, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
]
-
-newAttr :: HostName -> Attr
-newAttr hn = Attr hn 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