cadey
/
propellor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'joeyconfig'

This commit is contained in:
Joey Hess 2014-05-31 21:03:08 -04:00
parent 67549db9e9 179301f58d
commit 2588cab6a2
18 changed files with 240 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
config-joey.hs
View File

@ -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"

11
debian/changelog vendored
View File

@ -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.

5
doc/todo/docker_todo_list.mdwn
View File

@ -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.

8
propellor.cabal
View File

@ -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,

82
src/Propellor/Attr.hs
View File

@ -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)
alias = addDNS . CNAME . AbsDomain
addDNS :: Record -> SetAttr
addDNS record d = d { _dns = S.insert record (_dns d) }
-- | 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
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]
getNamedConf :: Propellor (M.Map Domain NamedConf)
getNamedConf = asks _namedconf
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)

23
src/Propellor/CmdLine.hs
View File

@ -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 ]

26
src/Propellor/Engine.hs
View File

@ -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

19
src/Propellor/Message.hs
View File

@ -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

3
src/Propellor/PrivData.hs
View File

@ -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

28
src/Propellor/Property.hs
View File

@ -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

34
src/Propellor/Property/Dns.hs
View File

@ -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

37
src/Propellor/Property/Docker.hs
View File

@ -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

2
src/Propellor/Property/Hostname.hs
View File

@ -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

2
src/Propellor/Property/Postfix.hs
View File

@ -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")

13
src/Propellor/Property/SiteSpecific/JoeySites.hs
View File

@ -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"
]

35
src/Propellor/Types.hs
View File

@ -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

37
src/Propellor/Types/Attr.hs
View File

@ -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

20
src/Propellor/Types/Dns.hs
View File

@ -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