summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-05-31 16:48:14 -0400
committerJoey Hess2014-05-31 16:48:14 -0400
commit6383d8c38893c160382eb9bf69e0315c5e87269e (patch)
tree63b3cf0c907df738fb227dc88d1dea5ea08a3c61 /src
parent1a83bf26300a225f044205e2208783e664377e25 (diff)
propellor spin
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Attr.hs26
-rw-r--r--src/Propellor/Property/Docker.hs24
2 files changed, 37 insertions, 13 deletions
diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs
index 98cfc64d..e2b64bf0 100644
--- a/src/Propellor/Attr.hs
+++ b/src/Propellor/Attr.hs
@@ -33,21 +33,31 @@ getOS = asks _os
-- 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) }
+addDNS :: Record -> Property
+addDNS r = pureAttrProperty (rdesc r) $
+ \d -> d { _dns = S.insert r (_dns d) }
+ where
+ 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 = "@"
-- | Adds a DNS NamedConf stanza.
--
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 68fbced5..465fe0b4 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.
@@ -54,7 +55,10 @@ 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 +66,16 @@ docked
:: [Host]
-> ContainerName
-> RevertableProperty
-docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
+docked hosts cn = RevertableProperty
+ (go "docked" setup)
+ (go "undocked" teardown)
where
go desc a = property (desc ++ " " ++ cn) $ do
hn <- getHostName
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 +94,19 @@ 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 containerdns)
+ where
+ containerdns = _dns $ containerattr $ newAttr undefined
+
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