summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Dns.hs
diff options
context:
space:
mode:
authorJoey Hess2014-05-14 19:41:05 -0400
committerJoey Hess2014-05-14 19:41:05 -0400
commit7115d1ec162b4059b3e8e8f84bd8d5898c1db025 (patch)
tree42c1cce54e890e1d56484794ab33129132d8fee2 /src/Propellor/Property/Dns.hs
parentffe371a9d42cded461236e972a24a142419d7fc4 (diff)
moved source code to src
This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work.
Diffstat (limited to 'src/Propellor/Property/Dns.hs')
-rw-r--r--src/Propellor/Property/Dns.hs405
1 files changed, 405 insertions, 0 deletions
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
new file mode 100644
index 00000000..5c3162cb
--- /dev/null
+++ b/src/Propellor/Property/Dns.hs
@@ -0,0 +1,405 @@
+module Propellor.Property.Dns (
+ module Propellor.Types.Dns,
+ primary,
+ secondary,
+ secondaryFor,
+ mkSOA,
+ writeZoneFile,
+ nextSerialNumber,
+ adjustSerialNumber,
+ serialNumberOffset,
+ WarningMessage,
+ genZone,
+) where
+
+import Propellor
+import Propellor.Types.Dns
+import Propellor.Property.File
+import Propellor.Types.Attr
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Service as Service
+import Utility.Applicative
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.List
+
+-- | Primary dns server for a domain.
+--
+-- Most of the content of the zone file is configured by setting properties
+-- of hosts. For example,
+--
+-- > host "foo.example.com"
+-- > & ipv4 "192.168.1.1"
+-- > & alias "mail.exmaple.com"
+--
+-- Will cause that hostmame and its alias to appear in the zone file,
+-- with the configured IP address.
+--
+-- The [(BindDomain, Record)] list can be used for additional records
+-- that cannot be configured elsewhere. This often includes NS records,
+-- TXT records and perhaps CNAMEs pointing at hosts that propellor does
+-- not control.
+--
+-- The primary server is configured to only allow zone transfers to
+-- secondary dns servers. These are determined in two ways:
+--
+-- 1. By looking at the properties of other hosts, to find hosts that
+-- are configured as the secondary dns server.
+--
+-- 2. By looking for NS Records in the passed list of records.
+--
+-- In either case, the secondary dns server Host should have an ipv4 and/or
+-- ipv6 property defined.
+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
+primary hosts domain soa rs = RevertableProperty setup cleanup
+ where
+ setup = withwarnings (check needupdate baseprop)
+ `requires` servingZones
+ `onChange` Service.reloaded "bind9"
+ cleanup = check (doesFileExist zonefile) $
+ property ("removed dns primary for " ++ domain)
+ (makeChange $ removeZoneFile zonefile)
+ `requires` namedConfWritten
+ `onChange` Service.reloaded "bind9"
+
+ (partialzone, zonewarnings) = genZone hosts domain soa
+ zone = partialzone { zHosts = zHosts partialzone ++ rs }
+ zonefile = "/etc/bind/propellor/db." ++ domain
+ baseprop = Property ("dns primary for " ++ domain)
+ (makeChange $ writeZoneFile zone zonefile)
+ (addNamedConf conf)
+ withwarnings p = adjustProperty p $ \satisfy -> do
+ mapM_ warningMessage $ zonewarnings ++ secondarywarnings
+ satisfy
+ conf = NamedConf
+ { confDomain = domain
+ , confDnsServerType = Master
+ , confFile = zonefile
+ , confMasters = []
+ , confAllowTransfer = nub $
+ concatMap (\h -> hostAddresses h hosts) $
+ secondaries ++ nssecondaries
+ , confLines = []
+ }
+ secondaries = otherServers Secondary hosts domain
+ secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $
+ filter (\h -> null (hostAddresses h hosts)) secondaries
+ nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords
+ rootRecords = map snd $
+ filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs
+ needupdate = do
+ v <- readZonePropellorFile zonefile
+ return $ case v of
+ Nothing -> True
+ Just oldzone ->
+ -- compare everything except serial
+ let oldserial = sSerialĀ (zSOA oldzone)
+ z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }
+ in z /= oldzone || oldserial < sSerial (zSOA zone)
+
+-- | Secondary dns server for a domain.
+--
+-- The primary server is determined by looking at the properties of other
+-- hosts to find which one is configured as the primary.
+--
+-- Note that if a host is declared to be a primary and a secondary dns
+-- server for the same domain, the primary server config always wins.
+secondary :: [Host] -> Domain -> RevertableProperty
+secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
+
+-- | This variant is useful if the primary server does not have its DNS
+-- configured via propellor.
+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
+secondaryFor masters hosts domain = RevertableProperty setup cleanup
+ where
+ setup = pureAttrProperty desc (addNamedConf conf)
+ `requires` servingZones
+ cleanup = namedConfWritten
+
+ desc = "dns secondary for " ++ domain
+ conf = NamedConf
+ { confDomain = domain
+ , confDnsServerType = Secondary
+ , confFile = "db." ++ domain
+ , confMasters = concatMap (\m -> hostAddresses m hosts) masters
+ , confAllowTransfer = []
+ , confLines = []
+ }
+
+otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
+otherServers wantedtype hosts domain =
+ M.keys $ M.filter wanted $ hostAttrMap hosts
+ where
+ wanted attr = case M.lookup domain (_namedconf attr) of
+ Nothing -> False
+ Just conf -> confDnsServerType conf == wantedtype
+ && confDomain conf == domain
+
+-- | Rewrites the whole named.conf.local file to serve the zones
+-- configured by `primary` and `secondary`, and ensures that bind9 is
+-- running.
+servingZones :: Property
+servingZones = namedConfWritten
+ `onChange` Service.reloaded "bind9"
+ `requires` Apt.serviceInstalledRunning "bind9"
+
+namedConfWritten :: Property
+namedConfWritten = property "named.conf configured" $ do
+ zs <- getNamedConf
+ ensureProperty $
+ hasContent namedConfFile $
+ concatMap confStanza $ M.elems zs
+
+confStanza :: NamedConf -> [Line]
+confStanza c =
+ [ "// automatically generated by propellor"
+ , "zone \"" ++ confDomain c ++ "\" {"
+ , cfgline "type" (if confDnsServerType c == Master then "master" else "slave")
+ , cfgline "file" ("\"" ++ confFile c ++ "\"")
+ ] ++
+ mastersblock ++
+ allowtransferblock ++
+ (map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
+ [ "};"
+ , ""
+ ]
+ where
+ cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
+ ipblock name l =
+ [ "\t" ++ name ++ " {" ] ++
+ (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++
+ [ "\t};" ]
+ mastersblock
+ | null (confMasters c) = []
+ | otherwise = ipblock "masters" (confMasters c)
+ -- an empty block prohibits any transfers
+ allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c)
+
+namedConfFile :: FilePath
+namedConfFile = "/etc/bind/named.conf.local"
+
+-- | Generates a SOA with some fairly sane numbers in it.
+--
+-- The Domain is the domain to use in the SOA record. Typically
+-- something like ns1.example.com. So, not the domain that this is the SOA
+-- record for.
+--
+-- The SerialNumber can be whatever serial number was used by the domain
+-- before propellor started managing it. Or 0 if the domain has only ever
+-- been managed by propellor.
+--
+-- You do not need to increment the SerialNumber when making changes!
+-- Propellor will automatically add the number of commits in the git
+-- repository to the SerialNumber.
+mkSOA :: Domain -> SerialNumber -> SOA
+mkSOA d sn = SOA
+ { sDomain = AbsDomain d
+ , sSerial = sn
+ , sRefresh = hours 4
+ , sRetry = hours 1
+ , sExpire = 2419200 -- 4 weeks
+ , sNegativeCacheTTL = hours 8
+ }
+ where
+ hours n = n * 60 * 60
+
+dValue :: BindDomain -> String
+dValue (RelDomain d) = d
+dValue (AbsDomain d) = d ++ "."
+dValue (RootDomain) = "@"
+
+rField :: Record -> String
+rField (Address (IPv4 _)) = "A"
+rField (Address (IPv6 _)) = "AAAA"
+rField (CNAME _) = "CNAME"
+rField (MX _ _) = "MX"
+rField (NS _) = "NS"
+rField (TXT _) = "TXT"
+rField (SRV _ _ _ _) = "SRV"
+
+rValue :: Record -> String
+rValue (Address (IPv4 addr)) = addr
+rValue (Address (IPv6 addr)) = addr
+rValue (CNAME d) = dValue d
+rValue (MX pri d) = show pri ++ " " ++ dValue d
+rValue (NS d) = dValue d
+rValue (SRV priority weight port target) = unwords
+ [ show priority
+ , show weight
+ , show port
+ , dValue target
+ ]
+rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]
+ where
+ q = '"'
+
+-- | Adjusts the serial number of the zone to always be larger
+-- than the serial number in the Zone record,
+-- and always be larger than the passed SerialNumber.
+nextSerialNumber :: Zone -> SerialNumber -> Zone
+nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial
+
+adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone
+adjustSerialNumber (Zone d soa l) f = Zone d soa' l
+ where
+ soa' = soa { sSerial = f (sSerial soa) }
+
+-- | Count the number of git commits made to the current branch.
+serialNumberOffset :: IO SerialNumber
+serialNumberOffset = fromIntegral . length . lines
+ <$> readProcess "git" ["log", "--pretty=%H"]
+
+-- | Write a Zone out to a to a file.
+--
+-- The serial number in the Zone automatically has the serialNumberOffset
+-- added to it. Also, just in case, the old serial number used in the zone
+-- file is checked, and if it is somehow larger, its succ is used.
+writeZoneFile :: Zone -> FilePath -> IO ()
+writeZoneFile z f = do
+ oldserial <- oldZoneFileSerialNumber f
+ offset <- serialNumberOffset
+ let z' = nextSerialNumber
+ (adjustSerialNumber z (+ offset))
+ oldserial
+ createDirectoryIfMissing True (takeDirectory f)
+ writeFile f (genZoneFile z')
+ writeZonePropellorFile f z'
+
+removeZoneFile :: FilePath -> IO ()
+removeZoneFile f = do
+ nukeFile f
+ nukeFile (zonePropellorFile f)
+
+-- | Next to the zone file, is a ".propellor" file, which contains
+-- the serialized Zone. This saves the bother of parsing
+-- the horrible bind zone file format.
+zonePropellorFile :: FilePath -> FilePath
+zonePropellorFile f = f ++ ".propellor"
+
+oldZoneFileSerialNumber :: FilePath -> IO SerialNumber
+oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile
+
+writeZonePropellorFile :: FilePath -> Zone -> IO ()
+writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)
+
+readZonePropellorFile :: FilePath -> IO (Maybe Zone)
+readZonePropellorFile f = catchDefaultIO Nothing $
+ readish <$> readFileStrict (zonePropellorFile f)
+
+-- | Generating a zone file.
+genZoneFile :: Zone -> String
+genZoneFile (Zone zdomain soa rs) = unlines $
+ header : genSOA soa ++ map (genRecord zdomain) rs
+ where
+ header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit."
+
+genRecord :: Domain -> (BindDomain, Record) -> String
+genRecord zdomain (domain, record) = intercalate "\t"
+ [ domainHost zdomain domain
+ , "IN"
+ , rField record
+ , rValue record
+ ]
+
+genSOA :: SOA -> [String]
+genSOA soa =
+ -- "@ IN SOA ns1.example.com. root ("
+ [ intercalate "\t"
+ [ dValue RootDomain
+ , "IN"
+ , "SOA"
+ , dValue (sDomain soa)
+ , "root"
+ , "("
+ ]
+ , headerline sSerial "Serial"
+ , headerline sRefresh "Refresh"
+ , headerline sRetry "Retry"
+ , headerline sExpire "Expire"
+ , headerline sNegativeCacheTTL "Negative Cache TTL"
+ , inheader ")"
+ ]
+ where
+ headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment
+ inheader l = "\t\t\t" ++ l
+
+-- | Comment line in a zone file.
+com :: String -> String
+com s = "; " ++ s
+
+type WarningMessage = String
+
+-- | Generates a Zone for a particular Domain from the DNS properies of all
+-- hosts that propellor knows about that are in that Domain.
+genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage])
+genZone hosts zdomain soa =
+ let (warnings, zhosts) = partitionEithers $ concat $ map concat
+ [ map hostips inzdomain
+ , map hostrecords inzdomain
+ , map addcnames (M.elems m)
+ ]
+ in (Zone zdomain soa (nub zhosts), warnings)
+ where
+ m = hostAttrMap hosts
+ -- Known hosts with hostname located in the zone's domain.
+ inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m
+
+ -- Each host with a hostname located in the zdomain
+ -- should have 1 or more IPAddrs in its Attr.
+ --
+ -- 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]
+ | otherwise = map Right l
+ where
+ l = zip (repeat $ AbsDomain $ _hostname attr)
+ (map Address $ getAddresses attr)
+
+ -- Any host, whether its hostname is in the zdomain or not,
+ -- may have cnames which are in the zdomain. The cname may even be
+ -- the same as the root of the zdomain, which is a nice way to
+ -- specify IP addresses for a SOA record.
+ --
+ -- Add Records for those.. But not actually, usually, cnames!
+ -- Why not? Well, using cnames doesn't allow doing some things,
+ -- including MX and round robin DNS, and certianly CNAMES
+ -- shouldn't be used in SOA records.
+ --
+ -- 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) $
+ mapMaybe getCNAME $ S.toList (_dns attr)
+ where
+ gen c = case getAddresses attr of
+ [] -> [ret (CNAME c)]
+ l -> map (ret . Address) l
+ where
+ 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
+ where
+ l = zip (repeat $ AbsDomain $ _hostname attr)
+ (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))
+
+inDomain :: Domain -> BindDomain -> Bool
+inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d
+inDomain _ _ = False -- can't tell, so assume not
+
+-- | Gets the hostname of the second domain, relative to the first domain,
+-- suitable for using in a zone file.
+domainHost :: Domain -> BindDomain -> String
+domainHost _ (RelDomain d) = d
+domainHost _ RootDomain = "@"
+domainHost base (AbsDomain d)
+ | dotbase `isSuffixOf` d = take (length d - length dotbase) d
+ | base == d = "@"
+ | otherwise = d
+ where
+ dotbase = '.':base
+