406 lines
13 KiB
Haskell
406 lines
13 KiB
Haskell
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
|
||
|